Merge branch 'master' into wip/ext-solverwip/ext-solver

1 files changed, 30 insertions, 9 deletions

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index ea2e17fb04..3bf07febf3 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -6,6 +6,8 @@
 Utility functions on @Core@ syntax
 
 \begin{code}
+{-# LANGUAGE CPP #-}
+
 -- | Commonly useful utilites for manipulating the Core language
 module CoreUtils (
         -- * Constructing expressions
@@ -215,7 +217,7 @@ mkCast expr co
 --    if to_ty `eqType` from_ty
 --    then expr
 --    else
-        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
+        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co))
          (Cast expr co)
 \end{code}
 
@@ -1222,7 +1224,7 @@ dataConInstPat :: [FastString]          -- A long enough list of FSs to use for
                -> [Unique]              -- An equally long list of uniques, at least one for each binder
                -> DataCon
                -> [Type]                -- Types to instantiate the universally quantified tyvars
-               -> ([TyVar], [Id])          -- Return instantiated variables
+               -> ([TyVar], [Id])       -- Return instantiated variables
 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
 -- (ex_tvs, arg_ids),
 --
@@ -1250,14 +1252,14 @@ dataConInstPat :: [FastString]          -- A long enough list of FSs to use for
 --
 --  where the double-primed variables are created with the FastStrings and
 --  Uniques given as fss and us
-dataConInstPat fss uniqs con inst_tys 
+dataConInstPat fss uniqs con inst_tys
   = ASSERT( univ_tvs `equalLength` inst_tys )
     (ex_bndrs, arg_ids)
-  where 
+  where
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
     arg_tys  = dataConRepArgTys con
-
+    arg_strs = dataConRepStrictness con  -- 1-1 with arg_tys
     n_ex = length ex_tvs
 
       -- split the Uniques and FastStrings
@@ -1268,7 +1270,7 @@ dataConInstPat fss uniqs con inst_tys
     univ_subst = zipOpenTvSubst univ_tvs inst_tys
 
       -- Make existential type variables, applyingn and extending the substitution
-    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst 
+    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst
                                        (zip3 ex_tvs ex_fss ex_uniqs)
 
     mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar)
@@ -1280,11 +1282,30 @@ dataConInstPat fss uniqs con inst_tys
         kind     = Type.substTy subst (tyVarKind tv)
 
       -- Make value vars, instantiating types
-    arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq 
-                                       (Type.substTy full_subst ty) noSrcSpan
+    arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs
+    mk_id_var uniq fs ty str
+      = mkLocalIdWithInfo name (Type.substTy full_subst ty) info
+      where
+        name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan
+        info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding
+             | otherwise          = vanillaIdInfo
+             -- See Note [Mark evaluated arguments]
 \end{code}
 
+Note [Mark evaluated arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When pattern matching on a constructor with strict fields, the binder
+can have an 'evaldUnfolding'.  Moreover, it *should* have one, so that
+when loading an interface file unfolding like:
+  data T = MkT !Int
+  f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1
+                             in ... }
+we don't want Lint to complain.  The 'y' is evaluated, so the
+case in the RHS of the binding for 'v' is fine.  But only if we
+*know* that 'y' is evaluated.
+
+c.f. add_evals in Simplify.simplAlt
+
 %************************************************************************
 %*                                                                      *
          Equality