[Git][ghc/ghc][wip/gc/aligned-block-allocation] 19 commits: gitlab-ci: Run nofib on binary distributions
Ömer Sinan Ağacan
gitlab at gitlab.haskell.org
Wed Jun 19 06:54:54 UTC 2019
Ömer Sinan Ağacan pushed to branch wip/gc/aligned-block-allocation at Glasgow Haskell Compiler / GHC
Commits:
24afbfe9 by Ben Gamari at 2019-06-17T14:20:32Z
gitlab-ci: Run nofib on binary distributions
Updates docker images to ensure that the `time` utility is available.
- - - - -
62f0213d by Fumiaki Kinoshita at 2019-06-18T20:00:20Z
Data.Ord: give a field name getDown to Down
- - - - -
da33f2bb by Fumiaki Kinoshita at 2019-06-18T20:00:20Z
Add more newtype-derived instances to Data.Ord.Down
Metric Increase:
haddock.base
- - - - -
dbf9ca20 by Ben Gamari at 2019-06-18T20:00:56Z
testsuite: Add testcase for #16689
- - - - -
29ec33cd by Ben Gamari at 2019-06-18T20:00:56Z
SafeHaskell: Don't throw -Wsafe warning if module is declared Safe
Fixes #16689.
- - - - -
a491e40c by Ben Gamari at 2019-06-18T20:01:31Z
hadrian: Compile UserSettings with -O0
This guarantees that the interface file for `UserSettings` doesn't
contain any unfoldings, ensuring that a change in it requires minimal
rebuilds.
- - - - -
74bd6b22 by Ben Gamari at 2019-06-18T20:02:07Z
testsuite: Add test for #16832
- - - - -
6a92f59d by Ben Gamari at 2019-06-18T20:02:42Z
gitlab-ci: Run alpine builds during nightly job
- - - - -
4549cadf by Andreas Klebinger at 2019-06-18T20:03:19Z
Make sure mkSplitUniqSupply stores the precomputed mask only.
mkSplitUniqSupply was lazy on the boxed char.
This caused a bunch of issues:
* The closure captured the boxed Char
* The mask was recomputed on every split of the supply.
* It also caused the allocation of MkSplitSupply to happen in it's own
(allocated) closure. The reason of which I did not further investigate.
We know force the computation of the mask inside mkSplitUniqSupply.
* This way the mask is computed at most once per UniqSupply creation.
* It allows ww to kick in, causing the closure to retain the unboxed
value.
Requesting Uniques in a loop is now faster by about 20%.
I did not check the impact on the overall compiler, but I added a test
to avoid regressions.
- - - - -
ef084f95 by Ömer Sinan Ağacan at 2019-06-19T05:59:37Z
rts/BlockAlloc: Allow aligned allocation requests
This implements support for block group allocations which are aligned to
an integral number of blocks.
This will be used by the nonmoving garbage collector, which uses the
block allocator to allocate the segments which back its heap. These
segments are a fixed number of blocks in size, with each segment being
aligned to the segment size boundary. This allows us to easily find the
segment metadata stored at the beginning of the segment.
- - - - -
f8f17be1 by Ben Gamari at 2019-06-19T05:59:37Z
testsuite/testblockalloc: A bit of refactoring
- - - - -
522a2ea0 by Ben Gamari at 2019-06-19T05:59:37Z
testsuite/testblockalloc: Test aligned block group allocation
- - - - -
4165fe6b by Ben Gamari at 2019-06-19T05:59:37Z
rts/BlockAlloc: Wibbles
- - - - -
e8e067b3 by Ben Gamari at 2019-06-19T05:59:37Z
rts/BlockAlloc: Use allocLargeChunk in aligned block allocation
- - - - -
3880c416 by Ömer Sinan Ağacan at 2019-06-19T05:59:37Z
Disallow allocating megablocks, update tests
- - - - -
a04329e3 by Ömer Sinan Ağacan at 2019-06-19T05:59:37Z
Fix lint errors
- - - - -
8c64914b by Ömer Sinan Ağacan at 2019-06-19T05:59:37Z
Use allocLargeChunkOnNode to reduce splitting
- - - - -
d551c22f by Ömer Sinan Ağacan at 2019-06-19T06:41:14Z
Disallow allocating megablocks, again
- - - - -
52e927bc by Ömer Sinan Ağacan at 2019-06-19T06:54:27Z
Comments
- - - - -
17 changed files:
- .gitlab-ci.yml
- compiler/basicTypes/UniqSupply.hs
- compiler/main/HscMain.hs
- hadrian/src/UserSettings.hs
- includes/rts/storage/Block.h
- libraries/base/Control/Monad/Fix.hs
- libraries/base/Data/Ord.hs
- libraries/base/changelog.md
- rts/sm/BlockAlloc.c
- + testsuite/tests/perf/should_run/UniqLoop.hs
- testsuite/tests/perf/should_run/all.T
- testsuite/tests/rts/testblockalloc.c
- + testsuite/tests/safeHaskell/safeInfered/T16689.hs
- testsuite/tests/safeHaskell/safeInfered/all.T
- + testsuite/tests/typecheck/should_compile/T16832.hs
- + testsuite/tests/typecheck/should_compile/T16832.script
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
- DOCKER_REV: 88e952f165f48cfb956ac9a2486a9263aa4f777c
+ DOCKER_REV: e517150438cd9df9564fb91adc4b42e2667b2bc1
# Sequential version number capturing the versions of all tools fetched by
# .gitlab/win32-init.sh.
@@ -24,7 +24,7 @@ stages:
- full-build # Build all the things
- cleanup # See Note [Cleanup after the shell executor]
- packaging # Source distribution, etc.
- - hackage # head.hackage testing
+ - testing # head.hackage correctness and compiler performance testing
- deploy # push documentation
# N.B.Don't run on wip/ branches, instead on run on merge requests.
@@ -580,7 +580,7 @@ release-x86_64-linux-deb8:
# x86_64-linux-alpine
#################################
-release-x86_64-linux-alpine:
+.build-x86_64-linux-alpine:
extends: .validate-linux
stage: full-build
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine:$DOCKER_REV"
@@ -592,14 +592,23 @@ release-x86_64-linux-alpine:
BIN_DIST_PREP_TAR_COMP: "bindistprep/ghc-x86_64-alpine-linux.tar.xz"
# Can't use ld.gold due to #13958.
CONFIGURE_ARGS: "--disable-ld-override"
- only:
- - tags
cache:
key: linux-x86_64-alpine
artifacts:
when: always
expire_in: 2 week
+release-x86_64-linux-alpine:
+ extends: .build-x86_64-linux-alpine
+ only:
+ - tags
+
+nightly-x86_64-linux-alpine:
+ extends: .build-x86_64-linux-alpine
+ only:
+ variables:
+ - $NIGHTLY
+
#################################
# x86_64-linux-centos7
#################################
@@ -903,7 +912,7 @@ source-tarball:
.hackage:
<<: *only-default
- stage: hackage
+ stage: testing
image: ghcci/x86_64-linux-deb9:0.2
tags:
- x86_64-linux
@@ -929,6 +938,47 @@ nightly-hackage:
variables:
- $NIGHTLY
+############################################################
+# Nofib testing
+############################################################
+
+perf-nofib:
+ stage: testing
+ dependencies:
+ - release-x86_64-linux-deb9-dwarf
+ image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
+ only:
+ refs:
+ - merge_requests
+ - master
+ - /ghc-[0-9]+\.[0-9]+/
+ tags:
+ - x86_64-linux
+ script:
+ - root=$(pwd)/ghc
+ - |
+ mkdir tmp
+ tar -xf ghc-*-x86_64-unknown-linux.tar.xz -C tmp
+ pushd tmp/ghc-*/
+ ./configure --prefix=$root
+ make install
+ popd
+ rm -Rf tmp
+ - export BOOT_HC=$(which ghc)
+ - cabal update; cabal install -w $BOOT_HC regex-compat
+ - export PATH=$root/bin:$PATH
+ - make -C nofib boot mode=fast -j$CPUS
+ - "make -C nofib EXTRA_RUNTEST_OPTS='-cachegrind +RTS -V0 -RTS' NoFibRuns=1 mode=fast -j$CPUS 2>&1 | tee nofib.log"
+ artifacts:
+ expire_in: 12 week
+ when: always
+ paths:
+ - nofib.log
+
+############################################################
+# Documentation deployment via GitLab Pages
+############################################################
+
pages:
stage: deploy
dependencies:
=====================================
compiler/basicTypes/UniqSupply.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE BangPatterns #-}
#if !defined(GHC_LOADED_INTO_GHCI)
{-# LANGUAGE UnboxedTuples #-}
@@ -88,7 +89,7 @@ takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
mkSplitUniqSupply c
= case ord c `shiftL` uNIQUE_BITS of
- mask -> let
+ !mask -> let
-- here comes THE MAGIC:
-- This is one of the most hammered bits in the whole compiler
=====================================
compiler/main/HscMain.hs
=====================================
@@ -520,7 +520,9 @@ tcRnModule' sum save_rn_syntax mod = do
safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
when safe $ do
case wopt Opt_WarnSafe dflags of
- True -> (logWarnings $ unitBag $
+ True
+ | safeHaskell dflags == Sf_Safe -> return ()
+ | otherwise -> (logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnSafe) $
mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
errSafe tcg_res')
=====================================
hadrian/src/UserSettings.hs
=====================================
@@ -1,3 +1,6 @@
+-- Ensure we don't expose any unfoldings to guarantee quick rebuilds
+{-# OPTIONS_GHC -O0 #-}
+
-- If you want to customise your build you should copy this file from
-- hadrian/src/UserSettings.hs to hadrian/UserSettings.hs and edit your copy.
-- If you don't copy the file your changes will be tracked by git and you can
=====================================
includes/rts/storage/Block.h
=====================================
@@ -290,6 +290,13 @@ EXTERN_INLINE bdescr* allocBlock(void)
bdescr *allocGroupOnNode(uint32_t node, W_ n);
+// Allocate n blocks, aligned at n-block boundary. The returned bdescr will
+// have this invariant
+//
+// bdescr->start % BLOCK_SIZE*n == 0
+//
+bdescr *allocAlignedGroupOnNode(uint32_t node, W_ n);
+
EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node);
EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node)
{
=====================================
libraries/base/Control/Monad/Fix.hs
=====================================
@@ -156,4 +156,3 @@ instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
-- | @since 4.12.0.0
instance MonadFix Down where
mfix f = Down (fix (getDown . f))
- where getDown (Down x) = x
=====================================
libraries/base/Data/Ord.hs
=====================================
@@ -7,7 +7,7 @@
-- Module : Data.Ord
-- Copyright : (c) The University of Glasgow 2005
-- License : BSD-style (see the file libraries/base/LICENSE)
---
+--
-- Maintainer : libraries at haskell.org
-- Stability : stable
-- Portability : portable
@@ -23,12 +23,18 @@ module Data.Ord (
comparing,
) where
+import Data.Bits (Bits, FiniteBits)
+import Foreign.Storable (Storable)
+import GHC.Arr (Ix)
import GHC.Base
-import GHC.Show
-import GHC.Read
+import GHC.Enum (Bounded, Enum)
+import GHC.Float (Floating, RealFloat)
import GHC.Num
+import GHC.Read
+import GHC.Real (Fractional, Integral, Real, RealFrac)
+import GHC.Show
--- |
+-- |
-- > comparing p x y = compare (p x) (p y)
--
-- Useful combinator for use in conjunction with the @xxxBy@ family
@@ -46,16 +52,44 @@ comparing p x y = compare (p x) (p y)
-- as in: @then sortWith by 'Down' x@
--
-- @since 4.6.0.0
-newtype Down a = Down a
+newtype Down a = Down
+ { getDown :: a -- ^ @since 4.14.0.0
+ }
deriving
( Eq -- ^ @since 4.6.0.0
- , Show -- ^ @since 4.7.0.0
- , Read -- ^ @since 4.7.0.0
, Num -- ^ @since 4.11.0.0
, Semigroup -- ^ @since 4.11.0.0
, Monoid -- ^ @since 4.11.0.0
+ , Bits -- ^ @since 4.14.0.0
+ , Bounded -- ^ @since 4.14.0.0
+ , Enum -- ^ @since 4.14.0.0
+ , FiniteBits -- ^ @since 4.14.0.0
+ , Floating -- ^ @since 4.14.0.0
+ , Fractional -- ^ @since 4.14.0.0
+ , Integral -- ^ @since 4.14.0.0
+ , Ix -- ^ @since 4.14.0.0
+ , Real -- ^ @since 4.14.0.0
+ , RealFrac -- ^ @since 4.14.0.0
+ , RealFloat -- ^ @since 4.14.0.0
+ , Storable -- ^ @since 4.14.0.0
)
+-- | This instance would be equivalent to the derived instances of the
+-- 'Down' newtype if the 'getDown' field were removed
+--
+-- @since 4.7.0.0
+instance (Read a) => Read (Down a) where
+ readsPrec d = readParen (d > 10) $ \ r ->
+ [(Down x,t) | ("Down",s) <- lex r, (x,t) <- readsPrec 11 s]
+
+-- | This instance would be equivalent to the derived instances of the
+-- 'Down' newtype if the 'getDown' field were removed
+--
+-- @since 4.7.0.0
+instance (Show a) => Show (Down a) where
+ showsPrec d (Down x) = showParen (d > 10) $
+ showString "Down " . showsPrec 11 x
+
-- | @since 4.6.0.0
instance Ord a => Ord (Down a) where
compare (Down x) (Down y) = y `compare` x
=====================================
libraries/base/changelog.md
=====================================
@@ -5,6 +5,12 @@
* Add a `TestEquality` instance for the `Compose` newtype.
+ * `Data.Ord.Down` now has a field name, `getDown`
+
+ * Add `Bits`, `Bounded`, `Enum`, `FiniteBits`, `Floating`, `Fractional`,
+ `Integral`, `Ix`, `Real`, `RealFrac`, `RealFloat` and `Storable` instances
+ to `Data.Ord.Down`.
+
* Fix the `integer-gmp` variant of `isValidNatural`: Previously it would fail
to detect values `<= maxBound::Word` that were incorrectly encoded using
the `NatJ#` constructor.
=====================================
rts/sm/BlockAlloc.c
=====================================
@@ -310,7 +310,7 @@ setup_tail (bdescr *bd)
// Take a free block group bd, and split off a group of size n from
// it. Adjust the free list as necessary, and return the new group.
static bdescr *
-split_free_block (bdescr *bd, uint32_t node, W_ n, uint32_t ln)
+split_free_block (bdescr *bd, uint32_t node, W_ n, uint32_t ln /* log_2_ceil(n) */)
{
bdescr *fg; // free group
@@ -325,6 +325,46 @@ split_free_block (bdescr *bd, uint32_t node, W_ n, uint32_t ln)
return fg;
}
+// Take N blocks off the end, free the rest.
+static bdescr *
+split_block_high (bdescr *bd, W_ n)
+{
+ ASSERT(bd->blocks > n);
+
+ bdescr* ret = bd + bd->blocks - n; // take n blocks off the end
+ ret->blocks = n;
+ ret->start = ret->free = bd->start + (bd->blocks - n)*BLOCK_SIZE_W;
+ ret->link = NULL;
+
+ bd->blocks -= n;
+
+ setup_tail(ret);
+ setup_tail(bd);
+ freeGroup(bd);
+
+ return ret;
+}
+
+// Like `split_block_high`, but takes n blocks off the beginning rather
+// than the end.
+static bdescr *
+split_block_low (bdescr *bd, W_ n)
+{
+ ASSERT(bd->blocks > n);
+
+ bdescr* bd_ = bd + n;
+ bd_->blocks = bd->blocks - n;
+ bd_->start = bd_->free = bd->start + n*BLOCK_SIZE_W;
+
+ bd->blocks = n;
+
+ setup_tail(bd_);
+ setup_tail(bd);
+ freeGroup(bd_);
+
+ return bd;
+}
+
/* Only initializes the start pointers on the first megablock and the
* blocks field of the first bdescr; callers are responsible for calling
* initGroup afterwards.
@@ -461,6 +501,108 @@ finish:
return bd;
}
+// Allocate `n` blocks aligned to `n` blocks, e.g. when n = 8, the blocks will
+// be aligned at `8 * BLOCK_SIZE`. For a group with `n` blocks this can be used
+// for easily accessing the beginning of the group from a location p in the
+// group with
+//
+// p % (BLOCK_SIZE*n)
+//
+// Used by the non-moving collector for allocating segments.
+//
+// Because the storage manager does not support aligned allocations, we have to
+// allocate `2*n - 1` blocks here to make sure we'll be able to find an aligned
+// region in the allocated blocks. After finding the aligned area we want to
+// free slop on the low and high sides, and block allocator doesn't support
+// freeing only some portion of a megablock (we can only free whole megablocks).
+// So we disallow allocating megablocks here, and allow allocating at most
+// `BLOCKS_PER_MBLOCK / 2` blocks.
+bdescr *
+allocAlignedGroupOnNode (uint32_t node, W_ n)
+{
+ // allocate enough blocks to have enough space aligned at n-block boundary
+ // free any slops on the low and high side of this space
+
+ // number of blocks to allocate to make sure we have enough aligned space
+ W_ num_blocks = 2*n - 1;
+
+ if (num_blocks >= BLOCKS_PER_MBLOCK) {
+ barf("allocAlignedGroupOnNode: allocating megablocks is not supported\n"
+ " requested blocks: %" FMT_Word "\n"
+ " required for alignment: %" FMT_Word "\n"
+ " megablock size (in blocks): %" FMT_Word,
+ n, num_blocks, BLOCKS_PER_MBLOCK);
+ }
+
+ W_ group_size = n * BLOCK_SIZE;
+
+ // To reduce splitting and fragmentation we use allocLargeChunkOnNode here.
+ // Tweak the max allocation to avoid allocating megablocks. Splitting slop
+ // below doesn't work with megablocks (freeGroup can't free only a portion
+ // of a megablock so we can't allocate megablocks and free some parts of
+ // them).
+ W_ max_blocks = stg_min(num_blocks * 3, BLOCKS_PER_MBLOCK - 1);
+ bdescr *bd = allocLargeChunkOnNode(node, num_blocks, max_blocks);
+ // We may allocate more than num_blocks, so update it
+ num_blocks = bd->blocks;
+
+ // slop on the low side
+ W_ slop_low = 0;
+ if ((uintptr_t)bd->start % group_size != 0) {
+ slop_low = group_size - ((uintptr_t)bd->start % group_size);
+ }
+
+ W_ slop_high = (num_blocks * BLOCK_SIZE) - group_size - slop_low;
+
+ ASSERT((slop_low % BLOCK_SIZE) == 0);
+ ASSERT((slop_high % BLOCK_SIZE) == 0);
+
+ W_ slop_low_blocks = slop_low / BLOCK_SIZE;
+ W_ slop_high_blocks = slop_high / BLOCK_SIZE;
+
+ ASSERT(slop_low_blocks + slop_high_blocks + n == num_blocks);
+
+#if defined(DEBUG)
+ checkFreeListSanity();
+ W_ free_before = countFreeList();
+#endif
+
+ if (slop_low_blocks != 0) {
+ bd = split_block_high(bd, num_blocks - slop_low_blocks);
+ ASSERT(countBlocks(bd) == num_blocks - slop_low_blocks);
+ }
+
+#if defined(DEBUG)
+ ASSERT(countFreeList() == free_before + slop_low_blocks);
+ checkFreeListSanity();
+#endif
+
+ // At this point the bd should be aligned, but we may have slop on the high side
+ ASSERT((uintptr_t)bd->start % group_size == 0);
+
+#if defined(DEBUG)
+ free_before = countFreeList();
+#endif
+
+ if (slop_high_blocks != 0) {
+ bd = split_block_low(bd, n);
+ ASSERT(bd->blocks == n);
+ }
+
+#if defined(DEBUG)
+ ASSERT(countFreeList() == free_before + slop_high_blocks);
+ checkFreeListSanity();
+#endif
+
+ // Should still be aligned
+ ASSERT((uintptr_t)bd->start % group_size == 0);
+
+ // Just to make sure I get this right
+ ASSERT(Bdescr(bd->start) == bd);
+
+ return bd;
+}
+
STATIC_INLINE
uint32_t nodeWithLeastBlocks (void)
{
=====================================
testsuite/tests/perf/should_run/UniqLoop.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Main where
+
+import UniqSupply
+import Unique
+
+-- Generate a lot of uniques
+main = do
+ us <- mkSplitUniqSupply 'v'
+ seq (churn us 10000000) (return ())
+
+churn :: UniqSupply -> Int -> Int
+churn !us 0 = getKey $ uniqFromSupply us
+churn us n =
+ let (!x,!us') = takeUniqFromSupply us
+ in churn us' (n-1)
=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -367,3 +367,11 @@ test('T15578',
only_ways(['normal'])],
compile_and_run,
['-O2'])
+
+# Test performance of creating Uniques.
+test('UniqLoop',
+ [collect_stats('bytes allocated',5),
+ only_ways(['normal'])
+ ],
+ compile_and_run,
+ ['-O -package ghc'])
\ No newline at end of file
=====================================
testsuite/tests/rts/testblockalloc.c
=====================================
@@ -3,6 +3,7 @@
#include <stdio.h>
extern bdescr *allocGroup_lock_lock(uint32_t n);
+extern bdescr *allocAlignedGroupOnNode (uint32_t node, W_ n);
extern void freeGroup_lock(bdescr *p);
const int ARRSIZE = 256;
@@ -13,64 +14,110 @@ const int SEED = 0xf00f00;
extern StgWord mblocks_allocated;
-int main (int argc, char *argv[])
+static void test_random_alloc(void)
{
- int i, j, b;
-
bdescr *a[ARRSIZE];
- srand(SEED);
+ // repeatedly sweep though the array, allocating new random-sized
+ // objects and deallocating the old ones.
+ for (int i=0; i < LOOPS; i++)
+ {
+ for (int j=0; j < ARRSIZE; j++)
+ {
+ if (i > 0)
+ {
+ IF_DEBUG(block_alloc, debugBelch("A%d: freeing %p, %d blocks @ %p\n", j, a[j], a[j]->blocks, a[j]->start));
+ freeGroup_lock(a[j]);
+ DEBUG_ONLY(checkFreeListSanity());
+ }
+
+ int b = (rand() % MAXALLOC) + 1;
+ a[j] = allocGroup_lock(b);
+ IF_DEBUG(block_alloc, debugBelch("A%d: allocated %p, %d blocks @ %p\n", j, a[j], b, a[j]->start));
+ // allocating zero blocks isn't allowed
+ DEBUG_ONLY(checkFreeListSanity());
+ }
+ }
+ for (int j=0; j < ARRSIZE; j++)
{
- RtsConfig conf = defaultRtsConfig;
- conf.rts_opts_enabled = RtsOptsAll;
- hs_init_ghc(&argc, &argv, conf);
+ freeGroup_lock(a[j]);
}
+}
+
+static void test_sequential_alloc(void)
+{
+ bdescr *a[ARRSIZE];
- // repeatedly sweep though the array, allocating new random-sized
- // objects and deallocating the old ones.
- for (i=0; i < LOOPS; i++)
- {
- for (j=0; j < ARRSIZE; j++)
- {
- if (i > 0)
- {
- IF_DEBUG(block_alloc, debugBelch("A%d: freeing %p, %d blocks @ %p\n", j, a[j], a[j]->blocks, a[j]->start));
- freeGroup_lock(a[j]);
- DEBUG_ONLY(checkFreeListSanity());
- }
- b = (rand() % MAXALLOC) + 1;
- a[j] = allocGroup_lock(b);
- IF_DEBUG(block_alloc, debugBelch("A%d: allocated %p, %d blocks @ %p\n", j, a[j], b, a[j]->start));
- // allocating zero blocks isn't allowed
- DEBUG_ONLY(checkFreeListSanity());
- }
- }
-
- for (j=0; j < ARRSIZE; j++)
- {
- freeGroup_lock(a[j]);
- }
-
// this time, sweep forwards allocating new blocks, and then
// backwards deallocating them.
- for (i=0; i < LOOPS; i++)
+ for (int i=0; i < LOOPS; i++)
{
- for (j=0; j < ARRSIZE; j++)
+ for (int j=0; j < ARRSIZE; j++)
{
- b = (rand() % MAXALLOC) + 1;
+ int b = (rand() % MAXALLOC) + 1;
a[j] = allocGroup_lock(b);
IF_DEBUG(block_alloc, debugBelch("B%d,%d: allocated %p, %d blocks @ %p\n", i, j, a[j], b, a[j]->start));
DEBUG_ONLY(checkFreeListSanity());
}
- for (j=ARRSIZE-1; j >= 0; j--)
+ for (int j=ARRSIZE-1; j >= 0; j--)
{
IF_DEBUG(block_alloc, debugBelch("B%d,%d: freeing %p, %d blocks @ %p\n", i, j, a[j], a[j]->blocks, a[j]->start));
freeGroup_lock(a[j]);
DEBUG_ONLY(checkFreeListSanity());
}
}
-
+}
+
+static void test_aligned_alloc(void)
+{
+ bdescr *a[ARRSIZE];
+
+ // this time, sweep forwards allocating new blocks, and then
+ // backwards deallocating them.
+ for (int i=0; i < LOOPS; i++)
+ {
+ for (int j=0; j < ARRSIZE; j++)
+ {
+ // allocAlignedGroupOnNode does not support allocating more than
+ // BLOCKS_PER_MBLOCK/2 blocks.
+ int b = rand() % (BLOCKS_PER_MBLOCK / 2);
+ if (b == 0) { b = 1; }
+ a[j] = allocAlignedGroupOnNode(0, b);
+ if ((((W_)(a[j]->start)) % (b*BLOCK_SIZE)) != 0)
+ {
+ barf("%p is not aligned to allocation size %d", a[j], b);
+ }
+ IF_DEBUG(block_alloc, debugBelch("B%d,%d: allocated %p, %d blocks @ %p\n", i, j, a[j], b, a[j]->start));
+ DEBUG_ONLY(checkFreeListSanity());
+ }
+ for (int j=ARRSIZE-1; j >= 0; j--)
+ {
+ IF_DEBUG(block_alloc, debugBelch("B%d,%d: freeing %p, %d blocks @ %p\n", i, j, a[j], a[j]->blocks, a[j]->start));
+ freeGroup_lock(a[j]);
+ DEBUG_ONLY(checkFreeListSanity());
+ }
+ }
+}
+
+int main (int argc, char *argv[])
+{
+ int i, j, b;
+
+ bdescr *a[ARRSIZE];
+
+ srand(SEED);
+
+ {
+ RtsConfig conf = defaultRtsConfig;
+ conf.rts_opts_enabled = RtsOptsAll;
+ hs_init_ghc(&argc, &argv, conf);
+ }
+
+ test_random_alloc();
+ test_sequential_alloc();
+ test_aligned_alloc();
+
DEBUG_ONLY(checkFreeListSanity());
hs_exit(); // will do a memory leak test
=====================================
testsuite/tests/safeHaskell/safeInfered/T16689.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE Safe #-}
+
+main = return ()
+
=====================================
testsuite/tests/safeHaskell/safeInfered/all.T
=====================================
@@ -64,3 +64,5 @@ test('UnsafeWarn07', normal, compile, [''])
# Chck -fwa-safe works
test('SafeWarn01', normal, compile, [''])
+test('T16689', normal, compile, ['-Wsafe'])
+
=====================================
testsuite/tests/typecheck/should_compile/T16832.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE InstanceSigs #-}
+
+module WorkingGenerics where
+import GHC.Generics
+
+-- type family DiffT (p :: * -> *) :: * -> *
+
+data Void deriving(Generic)
+
+class Diff a where
+ type family Patch a :: *
+ type Patch a = GPatch (Rep a) a
+
+ diff :: a -> a -> Patch a
+ default diff :: (Generic a, GDiff (Rep a), Patch a ~ (GPatch (Rep a)) a) => a -> a -> Patch a
+ diff a a' = gdiff (from a) (from a')
+
+class GDiff (gen :: * -> *) where
+ type family GPatch gen :: * -> *
+ gdiff :: gen a -> gen a -> (GPatch gen) a
+
+instance GDiff V1 where
+ type GPatch V1 = V1
+ gdiff v1 _ = undefined
+
+-- meta info, we simply tunnel through
+instance (GDiff f) => GDiff (M1 i t f) where
+ type GPatch (M1 i t f) = M1 i t (GPatch f)
+ gdiff (M1 x) (M1 x') = M1 $ gdiff x x'
+
+
+instance Diff Void
+
=====================================
testsuite/tests/typecheck/should_compile/T16832.script
=====================================
@@ -0,0 +1,2 @@
+:load T16832
+
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -682,3 +682,4 @@ test('UnliftedNewtypesForall', normal, compile, [''])
test('UnlifNewUnify', normal, compile, [''])
test('UnliftedNewtypesLPFamily', normal, compile, [''])
test('UnliftedNewtypesDifficultUnification', normal, compile, [''])
+test('T16832', normal, ghci_script, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/ead67e400308d2ee48f20dd99e33ea03d906e3b2...52e927bcb111ff7be9ff6ff0e61ae78e0b08223f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/ead67e400308d2ee48f20dd99e33ea03d906e3b2...52e927bcb111ff7be9ff6ff0e61ae78e0b08223f
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/20190619/82a8a75c/attachment-0001.html>
More information about the ghc-commits
mailing list