[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Update containers to v0.6.3.1
Marge Bot
gitlab at gitlab.haskell.org
Fri Sep 25 05:29:11 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4145daec by Simon Jakobi at 2020-09-25T01:28:51-04:00
Update containers to v0.6.3.1
See https://github.com/haskell/containers/issues/737
in case of doubt about the correct release tag.
- - - - -
e32f037f by Andreas Klebinger at 2020-09-25T01:28:51-04:00
Make sizeExpr strict in the size threshold to facilitate WW.
- - - - -
6c24b62b by Ben Gamari at 2020-09-25T01:28:52-04:00
ci.sh: Factor out common utilities
- - - - -
8b157c6d by Ben Gamari at 2020-09-25T01:28:52-04:00
ci: Add ad-hoc performance testing rule
- - - - -
f73ebcfd by Zubin Duggal at 2020-09-25T01:28:53-04:00
Stop removing definitions of record fields in GHC.Iface.Ext.Ast
- - - - -
43a946bb by Ben Gamari at 2020-09-25T01:28:54-04:00
gitlab-ci: Drop Darwin cleanup job
We now have a proper periodic clean-up script installed on the runners.
- - - - -
d243e384 by Sebastian Graf at 2020-09-25T01:28:54-04:00
Add regression tests for #18371
They have been fixed by !3959, I believe.
Fixes #18371.
- - - - -
475527ab by Sebastian Graf at 2020-09-25T01:28:54-04:00
Add a regression test for #18609
The egregious performance hits are gone since !4050.
So we fix #18609.
- - - - -
fcad0194 by Sebastian Graf at 2020-09-25T01:28:54-04:00
Accept new test output for #17218
The expected test output was plain wrong.
It has been fixed for a long time.
Thus we can close #17218.
- - - - -
8d2f50af by Sven Tennie at 2020-09-25T01:28:55-04:00
Print RET_BIG stack closures
A RET_BIG closure has a large bitmap that describes it's payload and can
be printed with printLargeBitmap().
Additionally, the output for payload closures of small and big bitmaps is
changed: printObj() is used to print a bit more information about what's
on the stack.
- - - - -
9595d6ec by Arnaud Spiwack at 2020-09-25T01:29:00-04:00
Pattern guards BindStmt always use multiplicity Many
Fixes #18439 .
The rhs of the pattern guard was consumed with multiplicity one, while
the pattern assumed it was Many. We use Many everywhere instead.
This is behaviour consistent with that of `case` expression. See #18738.
- - - - -
13ee6e65 by Krzysztof Gogolewski at 2020-09-25T01:29:02-04:00
Fix typed holes causing linearity errors (#18491)
- - - - -
21 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- + .gitlab/common.sh
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- libraries/containers
- rts/Printer.c
- testsuite/tests/driver/T10970.stdout
- + testsuite/tests/linear/should_compile/LinearHole.hs
- testsuite/tests/linear/should_compile/all.T
- + testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.hs
- + testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.stderr
- testsuite/tests/linear/should_fail/all.T
- testsuite/tests/pmcheck/should_compile/T17218.stderr
- + testsuite/tests/pmcheck/should_compile/T18371.hs
- + testsuite/tests/pmcheck/should_compile/T18371b.hs
- + testsuite/tests/pmcheck/should_compile/T18609.hs
- + testsuite/tests/pmcheck/should_compile/T18609.stderr
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -21,7 +21,6 @@ stages:
- quick-build # A very quick smoke-test to weed out broken commits
- build # A quick smoke-test to weed out broken commits
- full-build # Build all the things
- - cleanup # See Note [Cleanup after the shell executor]
- packaging # Source distribution, etc.
- testing # head.hackage correctness and compiler performance testing
- deploy # push documentation
@@ -923,44 +922,6 @@ release-x86_64-windows-integer-simple:
BIGNUM_BACKEND: native
BUILD_FLAVOUR: "perf"
-############################################################
-# Cleanup
-############################################################
-
-# Note [Cleaning up after shell executor]
-# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-#
-# As noted in [1], gitlab-runner's shell executor doesn't clean up its working
-# directory after builds. Unfortunately, we are forced to use the shell executor
-# on Darwin. To avoid running out of disk space we add a stage at the end of
-# the build to remove the /.../GitLabRunner/builds directory. Since we only run a
-# single build at a time on Darwin this should be safe.
-#
-# We used to have a similar cleanup job on Windows as well however it ended up
-# being quite fragile as we have multiple Windows builders yet there is no
-# guarantee that the cleanup job is run on the same machine as the build itself
-# was run. Consequently we were forced to instead handle cleanup with a separate
-# cleanup cron job on Windows.
-#
-# [1] https://gitlab.com/gitlab-org/gitlab-runner/issues/3856
-
-# See Note [Cleanup after shell executor]
-cleanup-darwin:
- stage: cleanup
- tags:
- - x86_64-darwin
- when: always
- dependencies: []
- before_script:
- - echo "Time to clean up"
- script:
- - echo "Let's go"
- after_script:
- - BUILD_DIR=$CI_PROJECT_DIR
- - echo "Cleaning $BUILD_DIR"
- - cd $HOME
- - rm -Rf $BUILD_DIR/*
- - exit 0
############################################################
# Packaging
@@ -1095,6 +1056,41 @@ perf-nofib:
paths:
- nofib.log
+############################################################
+# Ad-hoc performance testing
+############################################################
+
+perf:
+ stage: testing
+ dependencies:
+ - validate-x86_64-linux-deb9-dwarf
+ image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
+ rules:
+ - if: $CI_MERGE_REQUEST_ID
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
+ tags:
+ - x86_64-linux-perf
+ script:
+ - root=$(pwd)/ghc
+ - |
+ mkdir tmp
+ tar -xf ghc-x86_64-deb9-linux-dwarf.tar.xz -C tmp
+ pushd tmp/ghc-*/
+ ./configure --prefix=$root
+ make install
+ popd
+ rm -Rf tmp
+ - export BOOT_HC=$(which ghc)
+ - export HC=$root/bin/ghc
+ - .gitlab/ci.sh perf_test
+ artifacts:
+ expire_in: 12 week
+ when: always
+ paths:
+ - out
+
+
############################################################
# Documentation deployment via GitLab Pages
############################################################
=====================================
.gitlab/ci.sh
=====================================
@@ -10,54 +10,12 @@ hackage_index_state="2020-09-14T19:30:43Z"
MIN_HAPPY_VERSION="1.20"
MIN_ALEX_VERSION="3.2"
-# Colors
-BLACK="0;30"
-GRAY="1;30"
-RED="0;31"
-LT_RED="1;31"
-BROWN="0;33"
-LT_BROWN="1;33"
-GREEN="0;32"
-LT_GREEN="1;32"
-BLUE="0;34"
-LT_BLUE="1;34"
-PURPLE="0;35"
-LT_PURPLE="1;35"
-CYAN="0;36"
-LT_CYAN="1;36"
-WHITE="1;37"
-LT_GRAY="0;37"
-
-# GitLab Pipelines log section delimiters
-# https://gitlab.com/gitlab-org/gitlab-foss/issues/14664
-start_section() {
- name="$1"
- echo -e "section_start:$(date +%s):$name\015\033[0K"
-}
-
-end_section() {
- name="$1"
- echo -e "section_end:$(date +%s):$name\015\033[0K"
-}
-
-echo_color() {
- local color="$1"
- local msg="$2"
- echo -e "\033[${color}m${msg}\033[0m"
-}
-
-error() { echo_color "${RED}" "$1"; }
-warn() { echo_color "${LT_BROWN}" "$1"; }
-info() { echo_color "${LT_BLUE}" "$1"; }
-
-fail() { error "error: $1"; exit 1; }
-
-function run() {
- info "Running $*..."
- "$@" || ( error "$* failed"; return 1; )
-}
-
TOP="$(pwd)"
+if [ ! -d "$TOP/.gitlab" ]; then
+ echo "This script expects to be run from the root of a ghc checkout"
+fi
+
+source $TOP/.gitlab/common.sh
function setup_locale() {
# Musl doesn't provide locale support at all...
@@ -437,6 +395,34 @@ function test_hadrian() {
--test-compiler="$TOP"/_build/install/bin/ghc
}
+function cabal_test() {
+ if [ -z "$OUT" ]; then
+ fail "OUT not set"
+ fi
+
+ start_section "Cabal test: $OUT"
+ mkdir -p "$OUT"
+ run "$HC" \
+ -hidir tmp -odir tmp -fforce-recomp \
+ -ddump-to-file -dumpdir "$OUT/dumps" -ddump-timings \
+ +RTS --machine-readable "-t$OUT/rts.log" -RTS \
+ -package mtl -ilibraries/Cabal/Cabal libraries/Cabal/Cabal/Setup.hs \
+ $@
+ rm -Rf tmp
+ end_section "Cabal test: $OUT"
+}
+
+function run_perf_test() {
+ if [ -z "$HC" ]; then
+ fail "HC not set"
+ fi
+
+ mkdir -p out
+ OUT=out/Cabal-O0 cabal_test -O0
+ OUT=out/Cabal-O1 cabal_test -O1
+ OUT=out/Cabal-O2 cabal_test -O2
+}
+
function clean() {
rm -R tmp
run "$MAKE" --quiet clean || true
@@ -507,6 +493,7 @@ case $1 in
push_perf_notes
exit $res ;;
run_hadrian) run_hadrian $@ ;;
+ perf_test) run_perf_test ;;
clean) clean ;;
shell) shell $@ ;;
*) fail "unknown mode $1" ;;
=====================================
.gitlab/common.sh
=====================================
@@ -0,0 +1,50 @@
+# Common bash utilities
+# ----------------------
+
+# Colors
+BLACK="0;30"
+GRAY="1;30"
+RED="0;31"
+LT_RED="1;31"
+BROWN="0;33"
+LT_BROWN="1;33"
+GREEN="0;32"
+LT_GREEN="1;32"
+BLUE="0;34"
+LT_BLUE="1;34"
+PURPLE="0;35"
+LT_PURPLE="1;35"
+CYAN="0;36"
+LT_CYAN="1;36"
+WHITE="1;37"
+LT_GRAY="0;37"
+
+# GitLab Pipelines log section delimiters
+# https://gitlab.com/gitlab-org/gitlab-foss/issues/14664
+start_section() {
+ name="$1"
+ echo -e "section_start:$(date +%s):$name\015\033[0K"
+}
+
+end_section() {
+ name="$1"
+ echo -e "section_end:$(date +%s):$name\015\033[0K"
+}
+
+echo_color() {
+ local color="$1"
+ local msg="$2"
+ echo -e "\033[${color}m${msg}\033[0m"
+}
+
+error() { echo_color "${RED}" "$1"; }
+warn() { echo_color "${LT_BROWN}" "$1"; }
+info() { echo_color "${LT_BLUE}" "$1"; }
+
+fail() { error "error: $1"; exit 1; }
+
+function run() {
+ info "Running $*..."
+ "$@" || ( error "$* failed"; return 1; )
+}
+
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -16,6 +16,7 @@ find, unsurprisingly, a Core expression.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -394,7 +395,9 @@ sizeExpr :: UnfoldingOpts
-- Note [Computing the size of an expression]
-sizeExpr opts bOMB_OUT_SIZE top_args expr
+-- Forcing bOMB_OUT_SIZE early prevents repeated
+-- unboxing of the Int argument.
+sizeExpr opts !bOMB_OUT_SIZE top_args expr
= size_up expr
where
size_up (Cast e _) = size_up e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -42,7 +42,7 @@ import GHC.Driver.Types
import GHC.Unit.Module ( ModuleName, ml_hs_file )
import GHC.Utils.Monad ( concatMapM, liftIO )
import GHC.Types.Id ( isDataConId_maybe )
-import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc, nameUnique )
+import GHC.Types.Name ( Name, nameSrcSpan, nameUnique )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
import GHC.Types.SrcLoc
import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType )
@@ -52,7 +52,7 @@ import GHC.Core.InstEnv
import GHC.Builtin.Types ( mkListTy, mkSumTy )
import GHC.Tc.Types
import GHC.Tc.Types.Evidence
-import GHC.Types.Var ( Id, Var, EvId, setVarName, varName, varType, varUnique )
+import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique )
import GHC.Types.Var.Env
import GHC.Builtin.Uniques
import GHC.Iface.Make ( mkIfaceExports )
@@ -1276,26 +1276,22 @@ instance ( ToHie (RFContext (Located label))
, toHie expr
]
-removeDefSrcSpan :: Name -> Name
-removeDefSrcSpan n = setNameLoc n noSrcSpan
-
instance ToHie (RFContext (Located (FieldOcc GhcRn))) where
toHie (RFC c rhs (L nspan f)) = concatM $ case f of
FieldOcc name _ ->
- [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
+ [ toHie $ C (RecField c rhs) (L nspan name)
]
instance ToHie (RFContext (Located (FieldOcc GhcTc))) where
toHie (RFC c rhs (L nspan f)) = concatM $ case f of
FieldOcc var _ ->
- let var' = setVarName var (removeDefSrcSpan $ varName var)
- in [ toHie $ C (RecField c rhs) (L nspan var')
- ]
+ [ toHie $ C (RecField c rhs) (L nspan var)
+ ]
instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
Unambiguous name _ ->
- [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
+ [ toHie $ C (RecField c rhs) $ L nspan name
]
Ambiguous _name _ ->
[ ]
@@ -1303,13 +1299,11 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
Unambiguous var _ ->
- let var' = setVarName var (removeDefSrcSpan $ varName var)
- in [ toHie $ C (RecField c rhs) (L nspan var')
- ]
+ [ toHie $ C (RecField c rhs) (L nspan var)
+ ]
Ambiguous var _ ->
- let var' = setVarName var (removeDefSrcSpan $ varName var)
- in [ toHie $ C (RecField c rhs) (L nspan var')
- ]
+ [ toHie $ C (RecField c rhs) (L nspan var)
+ ]
instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -198,6 +198,8 @@ tcExpr e@(HsUnboundVar _ occ) res_ty
; name <- newSysName occ
; let ev = mkLocalId name Many ty
; emitNewExprHole occ ev ty
+ ; tcEmitBindingUsage bottomUE -- Holes fit any usage environment
+ -- (#18491)
; tcWrapResultO (UnboundOccurrenceOf occ) e
(HsUnboundVar ev occ) ty res_ty }
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -397,7 +397,14 @@ tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
+ = do { -- The Many on the next line and the unrestricted on the line after
+ -- are linked. These must be the same multiplicity. Consider
+ -- x <- rhs -> u
+ --
+ -- The multiplicity of x in u must be the same as the multiplicity at
+ -- which the rhs has been consumed. When solving #18738, we want these
+ -- two multiplicity to still be the same.
+ (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs
-- Stmt has a context already
; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
pat (unrestricted rhs_ty) $
=====================================
libraries/containers
=====================================
@@ -1 +1 @@
-Subproject commit aaeda192b34a66b1c5359a85271adf8fed26dd12
+Subproject commit 97fe43c54c5c8a9b93ecf5abd7509e8085b63d41
=====================================
rts/Printer.c
=====================================
@@ -476,7 +476,8 @@ printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
printPtr((P_)payload[i]);
- debugBelch("\n");
+ debugBelch(" -- ");
+ printObj((StgClosure*) payload[i]);
} else {
debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
}
@@ -498,7 +499,8 @@ printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
printPtr((P_)payload[i]);
- debugBelch("\n");
+ debugBelch(" -- ");
+ printObj((StgClosure*) payload[i]);
} else {
debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
}
@@ -509,7 +511,6 @@ printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
void
printStackChunk( StgPtr sp, StgPtr spBottom )
{
- StgWord bitmap;
const StgInfoTable *info;
ASSERT(sp <= spBottom);
@@ -587,7 +588,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
} else {
debugBelch("RET_SMALL (%p)\n", info);
}
- bitmap = info->layout.bitmap;
+ StgWord bitmap = info->layout.bitmap;
printSmallBitmap(spBottom, sp+1,
BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
continue;
@@ -605,8 +606,13 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
}
case RET_BIG:
- barf("todo");
-
+ debugBelch("RET_BIG (%p)\n", sp);
+ StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
+ printLargeBitmap(spBottom,
+ (StgPtr)((StgClosure *) sp)->payload,
+ bitmap,
+ bitmap->size);
+ continue;
case RET_FUN:
{
const StgFunInfoTable *fun_info;
@@ -697,7 +703,7 @@ void printLargeAndPinnedObjects()
for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
Capability *cap = capabilities[cap_idx];
- debugBelch("Capability %d: Current pinned object block: %p\n",
+ debugBelch("Capability %d: Current pinned object block: %p\n",
cap_idx, (void*)cap->pinned_object_block);
for (bdescr *bd = cap->pinned_object_blocks; bd; bd = bd->link) {
debugBelch("%p\n", (void*)bd);
=====================================
testsuite/tests/driver/T10970.stdout
=====================================
@@ -1,2 +1,2 @@
-0.6.2.1
+0.6.3.1
OK
=====================================
testsuite/tests/linear/should_compile/LinearHole.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE LinearTypes #-}
+{-# OPTIONS_GHC -fdefer-typed-holes -Wno-typed-holes #-}
+
+module LinearHole where -- #18491
+
+f :: Int #-> Bool #-> Char
+f x y = _1
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -35,3 +35,4 @@ test('MultConstructor', expect_broken(broken_multiplicity_syntax), compile, ['']
test('LinearLetRec', expect_broken(405), compile, ['-O -dlinear-core-lint'])
test('LinearTH1', normal, compile, [''])
test('LinearTH2', expect_broken(broken_multiplicity_syntax), compile, [''])
+test('LinearHole', normal, compile, [''])
=====================================
testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE LinearTypes #-}
+module LinearPatternGuardWildcard where
+
+-- See #18439
+
+unsafeConsume :: a #-> ()
+unsafeConsume x | _ <- x = ()
=====================================
testsuite/tests/linear/should_fail/LinearPatternGuardWildcard.stderr
=====================================
@@ -0,0 +1,5 @@
+
+LinearPatternGuardWildcard.hs:7:15: error:
+ • Couldn't match type ‘'Many’ with ‘'One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘unsafeConsume’: unsafeConsume x | _ <- x = ()
=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -27,3 +27,4 @@ test('LinearPolyType', expect_broken([436, broken_multiplicity_syntax]), compile
test('LinearBottomMult', normal, compile_fail, [''])
test('LinearSequenceExpr', normal, compile_fail, [''])
test('LinearIf', normal, compile_fail, [''])
+test('LinearPatternGuardWildcard', normal, compile_fail, [''])
=====================================
testsuite/tests/pmcheck/should_compile/T17218.stderr
=====================================
@@ -1,6 +1,4 @@
T17218.hs:11:1: warning: [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In an equation for ‘f’:
- Patterns not matched:
- C
+ In an equation for ‘f’: Patterns not matched: P
=====================================
testsuite/tests/pmcheck/should_compile/T18371.hs
=====================================
@@ -0,0 +1,46 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+module Bug where
+
+import Data.Kind
+import Unsafe.Coerce
+
+type family Sing :: k -> Type
+
+class SingI a where
+ sing :: Sing a
+
+data SingInstance :: forall k. k -> Type where
+ SingInstance :: SingI a => SingInstance a
+
+newtype DI (a :: k) = Don'tInstantiate (SingI a => SingInstance a)
+
+singInstance :: forall k (a :: k). Sing a -> SingInstance a
+singInstance s = with_sing_i SingInstance
+ where
+ with_sing_i :: (SingI a => SingInstance a) -> SingInstance a
+ with_sing_i si = unsafeCoerce (Don'tInstantiate si) s
+
+{-# COMPLETE Sing #-}
+pattern Sing :: forall k (a :: k). () => SingI a => Sing a
+pattern Sing <- (singInstance -> SingInstance)
+ where Sing = sing
+
+-----
+
+data SBool :: Bool -> Type where
+ SFalse :: SBool False
+ STrue :: SBool True
+type instance Sing = SBool
+
+f :: SBool b -> ()
+f Sing = ()
+
+g :: Sing (b :: Bool) -> ()
+g Sing = ()
=====================================
testsuite/tests/pmcheck/should_compile/T18371b.hs
=====================================
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+module Lib where
+
+type family T
+
+pattern P :: T
+pattern P <- _
+{-# COMPLETE P #-}
+
+data U = U
+type instance T = U
+
+f :: U -> ()
+f P = ()
=====================================
testsuite/tests/pmcheck/should_compile/T18609.hs
=====================================
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE BangPatterns, GADTs, DataKinds, KindSignatures, EmptyCase #-}
+
+-- | All examples from https://arxiv.org/abs/1702.02281
+module GarrigueLeNormand where
+
+import Data.Kind
+
+data N = Z | S N
+
+data Plus :: N -> N -> N -> Type where
+ PlusO :: Plus Z a a
+ PlusS :: !(Plus a b c) -> Plus (S a) b (S c)
+
+data SMaybe a = SJust !a | SNothing
+
+trivial :: SMaybe (Plus (S Z) Z Z) -> ()
+trivial SNothing = ()
+
+trivial2 :: Plus (S Z) Z Z -> ()
+trivial2 x = case x of {}
+
+easy :: SMaybe (Plus Z (S Z) Z) -> ()
+easy SNothing = ()
+
+easy2 :: Plus Z (S Z) Z -> ()
+easy2 x = case x of {}
+
+harder :: SMaybe (Plus (S Z) (S Z) (S Z)) -> ()
+harder SNothing = ()
+
+harder2 :: Plus (S Z) (S Z) (S Z) -> ()
+harder2 x = case x of {}
+
+invZero :: Plus a b c -> Plus c d Z -> ()
+invZero !_ !_ | False = ()
+invZero PlusO PlusO = ()
+
+data T a where
+ A :: T Int
+ B :: T Bool
+ C :: T Char
+ D :: T Float
+
+data U a b c d where
+ U :: U Int Int Int Int
+
+f :: T a -> T b -> T c -> T d
+ -> U a b c d
+ -> ()
+f !_ !_ !_ !_ !_ | False = ()
+f A A A A U = ()
+
+g :: T a -> T b -> T c -> T d
+ -> T e -> T f -> T g -> T h
+ -> U a b c d
+ -> U e f g h
+ -> ()
+g !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ | False = ()
+g A A A A A A A A U U = ()
=====================================
testsuite/tests/pmcheck/should_compile/T18609.stderr
=====================================
@@ -0,0 +1,13 @@
+
+T18609.hs:36:25: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘invZero’: invZero !_ !_ | False = ...
+
+T18609.hs:51:20: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘f’: f !_ !_ !_ !_ !_ | False = ...
+
+T18609.hs:59:35: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘g’:
+ g !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ | False = ...
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -96,7 +96,7 @@ test('T17215', expect_broken(17215), compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T17216', expect_broken(17216), compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
-test('T17218', expect_broken(17218), compile,
+test('T17218', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T17219', expect_broken(17219), compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
@@ -140,12 +140,18 @@ test('T18273', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18341', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T18371', normal, compile,
+ ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T18371b', normal, compile,
+ ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18478', collect_compiler_stats('bytes allocated',10), compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18533', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18572', normal, compile,
['-fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-overlapping-patterns'])
+test('T18609', normal, compile,
+ ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18670', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18708', normal, compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fce3cd4d2319c40355e2031a6d772280f0fe421...13ee6e65d5bf80af2105df559b6798a6368f9eb3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fce3cd4d2319c40355e2031a6d772280f0fe421...13ee6e65d5bf80af2105df559b6798a6368f9eb3
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/20200925/6158d1ce/attachment-0001.html>
More information about the ghc-commits
mailing list