diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2019-01-29 16:37:19 +0100 |
---|---|---|
committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2019-01-29 16:37:19 +0100 |
commit | aa00bdb2122991f07415e1f5f4850d929dad96a3 (patch) | |
tree | a8612ce019ec8e88656290519a6404e00802f398 | |
parent | 7cdcd3e12a5c3a337e36fa80c64bd72e5ef79b24 (diff) | |
download | haskell-aa00bdb2122991f07415e1f5f4850d929dad96a3.tar.gz |
Look through newtype wrappers (Trac #16254)wip/T16254
This allows exprIsConApp_maybe to detect that Size (I# 10)
is a constructor application when Size has a wrapper.
-rw-r--r-- | compiler/basicTypes/Id.hs | 6 | ||||
-rw-r--r-- | compiler/coreSyn/CoreOpt.hs | 26 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 1 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/Makefile | 5 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T16254.hs | 14 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T16254.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
7 files changed, 53 insertions, 1 deletions
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 5e91d26c2f..390e547df1 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 f4fc94d2ae..5ec1931275 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 9c425e72f0..49a89b27e3 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 277a5a664b..8577dea2a7 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/T16254.hs b/testsuite/tests/simplCore/should_compile/T16254.hs new file mode 100644 index 0000000000..3c1490c17c --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T16254.hs @@ -0,0 +1,14 @@ +-- variant of T5327, where we force the newtype to have a wrapper +{-# LANGUAGE GADTs, ExplicitForAll #-} +module T16254 where + +newtype Size a b where + Size :: forall b a. Int -> Size a b + +{-# INLINABLE val2 #-} +val2 = Size 17 + +-- In the core, we should see a comparison against 34#, i.e. constant +-- 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/simplCore/should_compile/T16254.stdout b/testsuite/tests/simplCore/should_compile/T16254.stdout new file mode 100644 index 0000000000..0cfbf08886 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T16254.stdout @@ -0,0 +1 @@ +2 diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 1f6ef0059f..e9ada8e149 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']) |