Fix dataToTag# argument evaluation

See #15696 for more details. We now always enter dataToTag# argument (done in
generated Cmm, in StgCmmExpr). Any high-level optimisations on dataToTag#
applications are done by the simplifier. Looking at tag bits (instead of
reading the info table) for small types is left to another diff.

Incorrect test T14626 is removed. We no longer do this optimisation (see
comment:44, comment:45, comment:60).

Comments and notes about special cases around dataToTag# are removed. We no
longer have any special cases around it in Core.

Other changes related to evaluating primops (seq# and dataToTag#) will be
pursued in follow-up diffs.

Test Plan: Validates with three regression tests

Reviewers: simonpj, simonmar, hvr, bgamari, dfeuer

Reviewed By: simonmar

Subscribers: rwbarton, carter

GHC Trac Issues: #15696

Differential Revision: https://phabricator.haskell.org/D5201

2 files changed, 4 insertions, 84 deletions

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 26706b1cdd..19b6364e1e 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -43,7 +43,6 @@ import Id
 import IdInfo
 import TysWiredIn
 import DataCon
-import PrimOp
 import BasicTypes
 import Module
 import UniqSupply
@@ -1071,10 +1070,6 @@ The type is the type of the entire application
 
 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
 maybeSaturate fn expr n_args
-  | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg
-                                                -- A gruesome special case
-  = saturateDataToTag sat_expr
-
   | hasNoBinding fn        -- There's no binding
   = return sat_expr
 
@@ -1085,52 +1080,7 @@ maybeSaturate fn expr n_args
     excess_arity = fn_arity - n_args
     sat_expr     = cpeEtaExpand excess_arity expr
 
--------------
-saturateDataToTag :: CpeApp -> UniqSM CpeApp
--- See Note [dataToTag magic]
-saturateDataToTag sat_expr
-  = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
-       ; eta_body' <- eval_data2tag_arg eta_body
-       ; return (mkLams eta_bndrs eta_body') }
-  where
-    eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
-    eval_data2tag_arg app@(fun `App` arg)
-        | exprIsHNF arg         -- Includes nullary constructors
-        = return app            -- The arg is evaluated
-        | otherwise                     -- Arg not evaluated, so evaluate it
-        = do { arg_id <- newVar (exprType arg)
-             ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
-             ; return (Case arg arg_id1 (exprType app)
-                            [(DEFAULT, [], fun `App` Var arg_id1)]) }
-
-    eval_data2tag_arg (Tick t app)    -- Scc notes can appear
-        = do { app' <- eval_data2tag_arg app
-             ; return (Tick t app') }
-
-    eval_data2tag_arg other     -- Should not happen
-        = pprPanic "eval_data2tag" (ppr other)
-
-{- Note [dataToTag magic]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We must ensure that the arg of data2TagOp is evaluated. So
-in general CorePrep does this transformation:
-  data2tag e   -->   case e of y -> data2tag y
-(yuk yuk) take into account the lambdas we've now introduced
-
-How might it not be evaluated?  Well, we might have floated it out
-of the scope of a `seq`, or dropped the `seq` altogether.
-
-We only do this if 'e' is not a WHNF.  But if it's a simple
-variable (common case) we need to know its evaluated-ness flag.
-Example:
-   data T = MkT !Bool
-   f v = case v of
-           MkT y -> dataToTag# y
-Here we don't want to generate an extra case on 'y', because it's
-already evaluated.  So we want to keep the evaluated-ness flag
-on y.  See Note [Preserve evaluated-ness in CorePrep].
-
-
+{-
 ************************************************************************
 *                                                                      *
                 Simple CoreSyn operations
@@ -1630,7 +1580,7 @@ cpCloneBndr env bndr
 
        -- Drop (now-useless) rules/unfoldings
        -- See Note [Drop unfoldings and rules]
-       -- and Note [Preserve evaluated-ness in CorePrep]
+       -- and Note [Preserve evaluatedness] in CoreTidy
        ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
                           -- Simplifier will set the Id's unfolding
 
@@ -1662,21 +1612,8 @@ We want to drop the unfolding/rules on every Id:
   - We are changing uniques, so if we didn't discard unfoldings/rules
     we'd have to substitute in them
 
-HOWEVER, we want to preserve evaluated-ness; see
-Note [Preserve evaluated-ness in CorePrep]
-
-Note [Preserve evaluated-ness in CorePrep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to preserve the evaluated-ness of each binder (via
-evaldUnfolding) for two reasons
-
-* In the code generator if we have
-     case x of y { Red -> e1; DEFAULT -> y }
-  we can return 'y' rather than entering it, if we know
-  it is evaluated (Trac #14626)
-
-* In the DataToTag magic (in CorePrep itself) we rely on
-  evaluated-ness.  See Note Note [dataToTag magic].
+HOWEVER, we want to preserve evaluated-ness;
+see Note [Preserve evaluatedness] in CoreTidy.
 -}
 
 ------------------------------------------------------------------------------
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 453d984ec4..6dfb1df462 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -1696,23 +1696,6 @@ Well, yes.  The primop accepts lifted arguments and does not
 evaluate them.  Indeed, in general primops are, well, primitive
 and do not perform evaluation.
 
-There is one primop, dataToTag#, which does /require/ a lifted
-argument to be evaluated.  To ensure this, CorePrep adds an
-eval if it can't see the argument is definitely evaluated
-(see [dataToTag magic] in CorePrep).
-
-We make no attempt to guarantee that dataToTag#'s argument is
-evaluated here.  Main reason: it's very fragile to test for the
-evaluatedness of a lifted argument.  Consider
-    case x of y -> let v = dataToTag# y in ...
-
-where x/y have type Int, say.  'y' looks evaluated (by the enclosing
-case) so all is well.  Now the FloatOut pass does a binder-swap (for
-very good reasons), changing to
-   case x of y -> let v = dataToTag# x in ...
-
-See also Note [dataToTag#] in primops.txt.pp.
-
 Bottom line:
   * in exprOkForSpeculation we simply ignore all lifted arguments.
   * except see Note [seq# and expr_ok] for an exception