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.

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'])