[commit: ghc] master: Fix push_bang_into_newtype when the pattern match has no arguments (062f112)
git at git.haskell.org
git at git.haskell.org
Wed Feb 8 03:40:33 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/062f112388ac879dc78a9a0c5a947894d20cd899/ghc
>---------------------------------------------------------------
commit 062f112388ac879dc78a9a0c5a947894d20cd899
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date: Tue Feb 7 21:35:32 2017 -0500
Fix push_bang_into_newtype when the pattern match has no arguments
Correct behaviour of push_bang_into_newtype when the pattern match has
no arguments. A user can write
```
newtype T = T Int
f :: T -> ()
f !(T {}) = ()
```
in which case we have to push the bang inwards through the newtype in
order to achieve the desired strictness properties. This patch fixes
this special case where the pattern match has no arguments to push the
bang onto. We now make up a wildcard pattern which is wrapped in the
bang pattern.
```
f (T !_) = ()
```
Reviewers: simonpj, austin, bgamari
Reviewed By: simonpj
Subscribers: simonpj, thomie
Differential Revision: https://phabricator.haskell.org/D3057
>---------------------------------------------------------------
062f112388ac879dc78a9a0c5a947894d20cd899
compiler/deSugar/Match.hs | 32 +++++++++++++++++-------
testsuite/tests/deSugar/should_compile/T13215.hs | 6 +++++
testsuite/tests/deSugar/should_compile/all.T | 1 +
testsuite/tests/deSugar/should_run/T9844.hs | 13 ++++++++++
testsuite/tests/deSugar/should_run/T9844.stderr | 2 ++
testsuite/tests/deSugar/should_run/T9844.stdout | 2 ++
6 files changed, 47 insertions(+), 9 deletions(-)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index f5c3cf5..53b719a 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -518,11 +518,16 @@ tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p
tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p
-- Data/newtype constructors
-tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args })
- | isNewTyCon (dataConTyCon dc) -- Newtypes: push bang inwards (Trac #9844)
- = tidy1 v (p { pat_args = push_bang_into_newtype_arg l args })
- | otherwise -- Data types: discard the bang
- = tidy1 v p
+tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
+ , pat_args = args
+ , pat_arg_tys = arg_tys })
+ -- Newtypes: push bang inwards (Trac #9844)
+ =
+ if isNewTyCon (dataConTyCon dc)
+ then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args })
+ else tidy1 v p -- Data types: discard the bang
+ where
+ (ty:_) = dataConInstArgTys dc arg_tys
-------------------
-- Default case, leave the bang there:
@@ -542,18 +547,24 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args
tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
-------------------
-push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails Id
+push_bang_into_newtype_arg :: SrcSpan
+ -> Type -- The type of the argument we are pushing
+ -- onto
+ -> HsConPatDetails Id -> HsConPatDetails Id
-- See Note [Bang patterns and newtypes]
-- We are transforming !(N p) into (N !p)
-push_bang_into_newtype_arg l (PrefixCon (arg:args))
+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
= ASSERT( null args)
PrefixCon [L l (BangPat arg)]
-push_bang_into_newtype_arg l (RecCon rf)
+push_bang_into_newtype_arg l _ty (RecCon rf)
| HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
= ASSERT( null flds)
RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
-push_bang_into_newtype_arg _ cd
+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
+ | HsRecFields { rec_flds = [] } <- rf
+ = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
+push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
{-
@@ -568,6 +579,9 @@ So what we do is to push the bang inwards, in the hope that it will
get discarded there. So we transform
!(N pat) into (N !pat)
+But what if there is nothing to push the bang onto? In at least one instance
+a user has written !(N {}) which we translate into (N !_). See #13215
+
\noindent
{\bf Previous @matchTwiddled@ stuff:}
diff --git a/testsuite/tests/deSugar/should_compile/T13215.hs b/testsuite/tests/deSugar/should_compile/T13215.hs
new file mode 100644
index 0000000..102bd90
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T13215.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE BangPatterns #-}
+module T13215 where
+
+newtype F = F Int
+
+foo !(F {}) = ()
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index d40f8eb..24b95a0 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -95,3 +95,4 @@ test('T11414', normal, compile, [''])
test('T12944', normal, compile, [''])
test('T12950', normal, compile, [''])
test('T13043', normal, compile, [''])
+test('T13215', normal, compile, [''])
diff --git a/testsuite/tests/deSugar/should_run/T9844.hs b/testsuite/tests/deSugar/should_run/T9844.hs
index e06628e..851f628 100644
--- a/testsuite/tests/deSugar/should_run/T9844.hs
+++ b/testsuite/tests/deSugar/should_run/T9844.hs
@@ -12,6 +12,19 @@ f1 :: N -> Int
f1 n = n `seq` case n of
N _ -> 0
+f2 :: N -> Int
+f2 n = case n of
+ !(N {}) -> 0
+
+f3 :: N -> Int
+f3 n = n `seq` case n of
+ N {} -> 0
+
+
+
main = do
print $ f0 (trace "evaluated f0" (N 1))
print $ f1 (trace "evaluated f1" (N 1))
+
+ print $ f2 (trace "evaluated f2" (N 1))
+ print $ f3 (trace "evaluated f3" (N 1))
diff --git a/testsuite/tests/deSugar/should_run/T9844.stderr b/testsuite/tests/deSugar/should_run/T9844.stderr
index c94d12f..6da33db 100644
--- a/testsuite/tests/deSugar/should_run/T9844.stderr
+++ b/testsuite/tests/deSugar/should_run/T9844.stderr
@@ -1,2 +1,4 @@
evaluated f0
evaluated f1
+evaluated f2
+evaluated f3
diff --git a/testsuite/tests/deSugar/should_run/T9844.stdout b/testsuite/tests/deSugar/should_run/T9844.stdout
index aa47d0d..44e0be8 100644
--- a/testsuite/tests/deSugar/should_run/T9844.stdout
+++ b/testsuite/tests/deSugar/should_run/T9844.stdout
@@ -1,2 +1,4 @@
0
0
+0
+0
More information about the ghc-commits
mailing list