[commit: ghc] wip/T16254: Look through newtype wrappers (Trac #16254) (aa00bdb)
git at git.haskell.org
git at git.haskell.org
Wed Jan 30 00:26:26 UTC 2019
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T16254
Link : http://ghc.haskell.org/trac/ghc/changeset/aa00bdb2122991f07415e1f5f4850d929dad96a3/ghc
>---------------------------------------------------------------
commit aa00bdb2122991f07415e1f5f4850d929dad96a3
Author: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io>
Date: Tue Jan 29 16:37:19 2019 +0100
Look through newtype wrappers (Trac #16254)
This allows exprIsConApp_maybe to detect that Size (I# 10)
is a constructor application when Size has a wrapper.
>---------------------------------------------------------------
aa00bdb2122991f07415e1f5f4850d929dad96a3
compiler/basicTypes/Id.hs | 6 +++++
compiler/coreSyn/CoreOpt.hs | 26 +++++++++++++++++++++-
compiler/coreSyn/CoreUtils.hs | 1 +
testsuite/tests/simplCore/should_compile/Makefile | 5 +++++
.../should_compile/{T5327.hs => T16254.hs} | 8 ++++---
.../should_compile/T16254.stdout} | 0
testsuite/tests/simplCore/should_compile/all.T | 1 +
7 files changed, 43 insertions(+), 4 deletions(-)
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 5e91d26..390e547 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -67,6 +67,7 @@ module Id (
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
+ isDataConWrapId_maybe,
isConLikeId, isBottomingId, idIsFrom,
hasNoBinding,
@@ -425,6 +426,7 @@ isClassOpId_maybe :: Id -> Maybe Class
isPrimOpId_maybe :: Id -> Maybe PrimOp
isFCallId_maybe :: Id -> Maybe ForeignCall
isDataConWorkId_maybe :: Id -> Maybe DataCon
+isDataConWrapId_maybe :: Id -> Maybe DataCon
isRecordSelector id = case Var.idDetails id of
RecSelId {} -> True
@@ -474,6 +476,10 @@ isDataConWorkId_maybe id = case Var.idDetails id of
DataConWorkId con -> Just con
_ -> Nothing
+isDataConWrapId_maybe id = case Var.idDetails id of
+ DataConWrapId con -> Just con
+ _ -> Nothing
+
isDataConId_maybe :: Id -> Maybe DataCon
isDataConId_maybe id = case Var.idDetails id of
DataConWorkId con -> Just con
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index f4fc94d..5ec1931 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -41,7 +41,7 @@ import OptCoercion ( optCoercion )
import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
import Coercion hiding ( substCo, substCoVarBndr )
-import TyCon ( tyConArity )
+import TyCon ( tyConArity, isNewTyCon )
import TysWiredIn
import PrelNames
import BasicTypes
@@ -803,6 +803,12 @@ exprIsConApp_maybe (in_scope, id_unf) expr
, let subst = mkOpenSubst in_scope (bndrs `zip` args)
= pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
+ -- See Note [Looking through newtype wrappers]
+ | Just a <- isDataConWrapId_maybe fun
+ , isNewTyCon (dataConTyCon a)
+ , let rhs = uf_tmpl (realIdUnfolding fun)
+ = dealWithNewtypeWrapper (Left in_scope) rhs cont
+
-- Look through unfoldings, but only arity-zero one;
-- if arity > 0 we are effectively inlining a function call,
-- and that is the business of callSiteInline.
@@ -824,6 +830,24 @@ exprIsConApp_maybe (in_scope, id_unf) expr
go _ _ _ = Nothing
+ {-
+ Note [Looking through newtype wrappers]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ exprIsConApp_maybe should look through newtypes; for example,
+ Size (I# 10) is an application of constructor I# to argument 10
+ via some coercion c.
+
+ For newtypes without a wrapper, this becomes I# 10 `cast` c,
+ and we check for casts. See Trac #5327.
+ For newtypes with a wrapper, we must simplify (\x -> x `cast` c) (I# 10),
+ which is done by dealWithNewtypeWrapper. See Trac #16254 and T16254.
+
+ dealWithNewtypeWrapper is recursive since newtypes can have
+ multiple type arguments.
+ -}
+ dealWithNewtypeWrapper scope (Lam v body) (CC (arg:args) co) =
+ dealWithNewtypeWrapper (extend scope v arg) body (CC args co)
+ dealWithNewtypeWrapper scope expr args = go scope expr args
----------------------------
-- Operations on the (Either InScopeSet CoreSubst)
-- The Left case is wildly dominant
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 9c425e7..49a89b2 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -1360,6 +1360,7 @@ isExpandableApp fn n_val_args
| otherwise
= case idDetails fn of
DataConWorkId {} -> True -- Actually handled by isWorkFreeApp
+ DataConWrapId {} -> True
RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
ClassOpId {} -> n_val_args == 1
PrimOpId {} -> False
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile
index 277a5a6..8577dea 100644
--- a/testsuite/tests/simplCore/should_compile/Makefile
+++ b/testsuite/tests/simplCore/should_compile/Makefile
@@ -139,6 +139,11 @@ T5327:
$(RM) -f T5327.hi T5327.o
'$(TEST_HC)' $(TEST_HC_OPTS) -c T5327.hs -O -ddump-simpl | grep -c '># 34# '
+.PHONY: T16254
+T16254:
+ $(RM) -f T16254.hi T16254.o
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T16254.hs -O -ddump-simpl | grep -c '># 34# '
+
.PHONY: T5623
T5623:
$(RM) -f T5623.hi T5623.o
diff --git a/testsuite/tests/simplCore/should_compile/T5327.hs b/testsuite/tests/simplCore/should_compile/T16254.hs
similarity index 58%
copy from testsuite/tests/simplCore/should_compile/T5327.hs
copy to testsuite/tests/simplCore/should_compile/T16254.hs
index a2d9c01..3c1490c 100644
--- a/testsuite/tests/simplCore/should_compile/T5327.hs
+++ b/testsuite/tests/simplCore/should_compile/T16254.hs
@@ -1,6 +1,9 @@
-module T5327 where
+-- variant of T5327, where we force the newtype to have a wrapper
+{-# LANGUAGE GADTs, ExplicitForAll #-}
+module T16254 where
-newtype Size = Size Int
+newtype Size a b where
+ Size :: forall b a. Int -> Size a b
{-# INLINABLE val2 #-}
val2 = Size 17
@@ -9,4 +12,3 @@ val2 = Size 17
-- folding should have happened. We actually see it twice: Once in f's
-- definition, and once in its unfolding.
f n = case val2 of Size s -> s + s > n
-
diff --git a/testsuite/tests/codeGen/should_run/T9533c.stdout b/testsuite/tests/simplCore/should_compile/T16254.stdout
similarity index 100%
copy from testsuite/tests/codeGen/should_run/T9533c.stdout
copy to testsuite/tests/simplCore/should_compile/T16254.stdout
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 1f6ef00..e9ada8e 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -120,6 +120,7 @@ test('T5359b', normal, compile, ['']) # Lint error with -O (OccurAnal)
test('T5458', normal, compile, [''])
test('simpl021', [extra_files(['Simpl021A.hs', 'Simpl021B.hs'])], run_command, ['$MAKE -s --no-print-directory simpl021'])
test('T5327', normal, run_command, ['$MAKE -s --no-print-directory T5327'])
+test('T16254', normal, run_command, ['$MAKE -s --no-print-directory T16254'])
test('T5615', normal, run_command, ['$MAKE -s --no-print-directory T5615'])
test('T5623', normal, run_command, ['$MAKE -s --no-print-directory T5623'])
test('T13155', normal, run_command, ['$MAKE -s --no-print-directory T13155'])
More information about the ghc-commits
mailing list