[commit: ghc] wip/T12618: mkCoreConApps: Do not use ConApp for newtypes (ba8341c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/ba8341c129bb26e8d92e763dd7de6f0a1e265caf/ghc

>---------------------------------------------------------------

commit ba8341c129bb26e8d92e763dd7de6f0a1e265caf
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Oct 5 23:08:34 2016 -0400

    mkCoreConApps: Do not use ConApp for newtypes


>---------------------------------------------------------------

ba8341c129bb26e8d92e763dd7de6f0a1e265caf
 compiler/coreSyn/CoreLint.hs   |  4 +++-
 compiler/coreSyn/MkCore.hs     | 11 ++++++-----
 compiler/deSugar/DsBinds.hs    |  2 +-
 compiler/simplCore/Simplify.hs |  2 +-
 4 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 1c48dcd..02b2a36 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -715,7 +715,9 @@ lintCoreExpr e@(ConApp dc args)
             failWithL $ text "Found StaticPtr nested in an expression: " <+>
                         ppr e
          when (length args /= dataConRepFullArity dc) $
-            failWithL $ hang (text "Un-saturated data con application") 2 (ppr e)
+            addErrL $ hang (text "Un-saturated data con application") 2 (ppr e)
+         when (isNewTyCon (dataConTyCon dc)) $
+            addErrL $ hang (text "ConApp with newtype constructor") 2 (ppr e)
          let dc_ty = dataConRepType dc
          addLoc (AnExpr e) $ foldM lintCoreArg dc_ty args
 
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index a5f0871..01c5104 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -67,7 +67,8 @@ import TcType           ( mkSpecSigmaTy )
 import Type
 import Coercion         ( isCoVar )
 import TysPrim
-import DataCon          ( DataCon, dataConRepFullArity, dataConWrapId )
+import DataCon          ( DataCon, dataConRepFullArity, dataConWrapId, dataConTyCon )
+import TyCon            ( isNewTyCon )
 import IdInfo           ( vanillaIdInfo, setStrictnessInfo,
                           setArityInfo )
 import Demand
@@ -152,17 +153,17 @@ mkCoreApps orig_fun orig_args
 mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
 mkCoreConApps con args
     | length args >= dataConRepFullArity con
+    , not (isNewTyCon (dataConTyCon con))
     = let sat_app = mk_val_apps 0 res_ty (ConApp con) con_args
       in  mkCoreApps sat_app extra_args
+    | otherwise
+    -- Unsaturated or newtype constructor application.
+    = mkCoreApps (Var (dataConWrapId con)) args
   where
     -- TODO #12618: Can there ever be more than dataConRepArity con arguments
     -- in a type-safe program?
     (con_args, extra_args) = splitAt (dataConRepFullArity con) args
     res_ty = exprType (ConApp con args)
-mkCoreConApps con args
-    -- Unsaturated application. TODO #12618 Use wrapper.
-    = WARN ( True, text "mkCoreConApps: Unsaturated use." $$ ppr con <+> ppr args )
-      mkCoreApps (Var (dataConWrapId con)) args
 
 mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
 -- Build an application (e1 e2),
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 143d209..5c3bfcf 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1138,7 +1138,7 @@ dsEvTypeable ty ev
                       $ mkLams [mkWildValBinder proxyT] (Var repName)
 
        -- Package up the method as `Typeable` dictionary
-       ; return $ mkConApp typeable_data_con [Type kind, Type ty, method] }
+       ; return $ mkCoreConApps typeable_data_con [Type kind, Type ty, method] }
 
 
 ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 2644cc3..637139c 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -473,7 +473,7 @@ prepareRhs top_lvl env0 id rhs0
         = do { (is_exp, env', rhs') <- go n_val_args env rhs
              ; return (is_exp, env', Cast rhs' co) }
     go n_val_args env (ConApp dc args)
-        = ASSERT2( n_val_args == 0, ppr (ConApp dc args) <+> ppr n_val_args )
+        = WARN( n_val_args > 0, ppr (ConApp dc args) <+> ppr n_val_args )
           do { (env', args') <- makeTrivials top_lvl env (getOccFS id) args
              ; return (True, env', ConApp dc args')
              }