Fix dataToTag# argument evaluation
authorÖmer Sinan Ağacan <omeragacan@gmail.com>
Wed, 10 Oct 2018 07:07:05 +0000 (10:07 +0300)
committerÖmer Sinan Ağacan <omeragacan@gmail.com>
Wed, 10 Oct 2018 07:07:21 +0000 (10:07 +0300)
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

18 files changed:
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmPrim.hs
compiler/coreSyn/CorePrep.hs
compiler/coreSyn/CoreUtils.hs
compiler/prelude/PrelRules.hs
compiler/prelude/PrimOp.hs
compiler/prelude/primops.txt.pp
libraries/base/GHC/Base.hs
testsuite/tests/codeGen/should_compile/Makefile
testsuite/tests/codeGen/should_compile/T14626.hs [deleted file]
testsuite/tests/codeGen/should_compile/all.T
testsuite/tests/codeGen/should_run/T15696_1.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/T15696_1.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/T15696_2.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/T15696_2.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/T15696_3.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/T15696_3.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/all.T

index 22fcfaf..1af8fb3 100644 (file)
@@ -65,6 +65,16 @@ cgExpr (StgApp fun args)     = cgIdApp fun args
 cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
   cgIdApp a []
 
+-- dataToTag# :: a -> Int#
+-- See Note [dataToTag#] in primops.txt.pp
+cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
+  dflags <- getDynFlags
+  emitComment (mkFastString "dataToTag#")
+  tmp <- newTemp (bWord dflags)
+  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
+  -- TODO: For small types look at the tag bits instead of reading info table
+  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]
+
 cgExpr (StgOpApp op args ty) = cgOpApp op args ty
 cgExpr (StgConApp con args _)= cgConApp con args
 cgExpr (StgTick t e)         = cgTick t >> cgExpr e
@@ -550,6 +560,8 @@ isSimpleScrut _                _           = return False
 isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
 -- True iff the op cannot block or allocate
 isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
+isSimpleOp (StgPrimOp DataToTagOp) _ = return False
 isSimpleOp (StgPrimOp op) stg_args                  = do
     arg_exprs <- getNonVoidArgAmodes stg_args
     dflags <- getDynFlags
index f5437c0..c90264f 100644 (file)
@@ -37,7 +37,6 @@ import BlockId
 import MkGraph
 import StgSyn
 import Cmm
-import CmmInfo
 import Type     ( Type, tyConAppTyCon )
 import TyCon
 import CLabel
@@ -363,11 +362,6 @@ emitPrimOp _      [res] AddrToAnyOp [arg]
 emitPrimOp _      [res] AnyToAddrOp [arg]
    = emitAssign (CmmLocal res) arg
 
---  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
---  Note: argument may be tagged!
-emitPrimOp dflags [res] DataToTagOp [arg]
-   = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))
-
 {- Freezing arrays-of-ptrs requires changing an info table, for the
    benefit of the generational collector.  It needs to scavenge mutable
    objects, even if they are in old space.  When they become immutable,
index 26706b1..19b6364 100644 (file)
@@ -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.
 -}
 
 ------------------------------------------------------------------------------
index 453d984..6dfb1df 100644 (file)
@@ -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
index e944900..28c0628 100644 (file)
@@ -1030,19 +1030,6 @@ dataToTagRule = a `mplus` b
       guard $ ty1 `eqType` ty2
       return tag
 
-    -- Why don't we simplify tagToEnum# (dataToTag# x) to x? We would
-    -- like to, but it seems tricky. See #14282. The trouble is that
-    -- we never actually see tagToEnum# (dataToTag# x). Because dataToTag#
-    -- is can_fail, this expression is immediately transformed into
-    --
-    --   case dataToTag# @T x of wild
-    --     { __DEFAULT -> tagToEnum# @T wild }
-    --
-    -- and wild has no unfolding. Simon Peyton Jones speculates one way around
-    -- might be to arrange to give unfoldings to case binders of CONLIKE
-    -- applications and mark dataToTag# CONLIKE, but he doubts it's really
-    -- worth the trouble.
-
     -- dataToTag (K e1 e2)  ==>   tag-of K
     -- This also works (via exprIsConApp_maybe) for
     --   dataToTag x
index 4eb94e9..369f17f 100644 (file)
@@ -279,7 +279,6 @@ Invariants:
 
 These primops are pretty weird.
 
-        dataToTag# :: a -> Int    (arg must be an evaluated data type)
         tagToEnum# :: Int -> a    (result type must be an enumerated type)
 
 The constraints aren't currently checked by the front end, but the
index 7360ccb..303c902 100644 (file)
@@ -1070,7 +1070,7 @@ primop  CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp
    to the destination array. The source and destination arrays can
    refer to the same array. Both arrays must fully contain the
    specified ranges, but this is not checked.
-   The regions are allowed to overlap, although this is only possible when the same 
+   The regions are allowed to overlap, although this is only possible when the same
    array is provided as both the source and the destination. }
   with
   out_of_line      = True
@@ -1940,7 +1940,7 @@ primop  CopyMutableArrayArrayOp "copyMutableArrayArray#" GenPrimOp
   {Copy a range of the first MutableArrayArray# to the specified region in the second
    MutableArrayArray#.
    Both arrays must fully contain the specified ranges, but this is not checked.
-   The regions are allowed to overlap, although this is only possible when the same 
+   The regions are allowed to overlap, although this is only possible when the same
    array is provided as both the source and the destination.
    }
   with
@@ -2915,7 +2915,7 @@ primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
 
 -- Note [reallyUnsafePtrEquality#]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- 
+--
 -- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it can_fail
 -- anyway. Until 5a9a1738023a, GHC considered primops okay for speculation only
 -- when their arguments were known to be forced. This was unnecessarily
@@ -2924,22 +2924,20 @@ primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
 -- sometimes lose track of whether those arguments were forced, leading to let/app
 -- invariant failures (see Trac 13027 and the discussion in Trac 11444). Now that
 -- ok_for_speculation skips over lifted arguments, we need to explicitly prevent
--- reallyUnsafePtrEquality# from floating out. The reasons are closely related
--- to those described in Note [dataToTag#], although the consequences are less
--- severe. Imagine if we had
--- 
+-- reallyUnsafePtrEquality# from floating out. Imagine if we had
+--
 --     \x y . case x of x'
 --              DEFAULT ->
 --            case y of y'
 --              DEFAULT ->
 --               let eq = reallyUnsafePtrEquality# x' y'
 --               in ...
--- 
+--
 -- If the let floats out, we'll get
--- 
+--
 --     \x y . let eq = reallyUnsafePtrEquality# x y
 --            in case x of ...
--- 
+--
 -- The trouble is that pointer equality between thunks is very different
 -- from pointer equality between the values those thunks reduce to, and the latter
 -- is typically much more precise.
@@ -2990,31 +2988,29 @@ primop  DataToTagOp "dataToTag#" GenPrimOp
    with
    can_fail   = True -- See Note [dataToTag#]
    strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topRes }
-                -- dataToTag# must have an evaluated argument
 
 primop  TagToEnumOp "tagToEnum#" GenPrimOp
    Int# -> a
 
 -- Note [dataToTag#]
--- ~~~~~~~~~~~~~~~~~~~~
--- The dataToTag# primop should always be applied to an evaluated argument.
--- The way to ensure this is to invoke it via the 'getTag' wrapper in GHC.Base:
---    getTag :: a -> Int#
---    getTag !x = dataToTag# x
+-- ~~~~~~~~~~~~~~~~~
+-- dataToTag# evaluates its argument, so we don't want to float it out.
+-- Consider:
 --
--- But now consider
 --     \z. case x of y -> let v = dataToTag# y in ...
 --
 -- To improve floating, the FloatOut pass (deliberately) does a
 -- binder-swap on the case, to give
+--
 --     \z. case x of y -> let v = dataToTag# x in ...
 --
--- Now FloatOut might float that v-binding outside the \z.  But that is
--- bad because that might mean x gets evaluated much too early!  (CorePrep
--- adds an eval to a dataToTag# call, to ensure that the argument really is
--- evaluated; see CorePrep Note [dataToTag magic].)
+-- Now FloatOut might float that v-binding outside the \z
+--
+--     let v = dataToTag# x in \z. case x of y -> ...
+--
+-- But that is bad because that might mean x gets evaluated much too early!
 --
--- Solution: make DataToTag into a can_fail primop.  That will stop it floating
+-- Solution: make dataToTag# into a can_fail primop.  That will stop it floating
 -- (see Note [PrimOp can_fail and has_side_effects] in PrimOp).  It's a bit of
 -- a hack but never mind.
 
@@ -3126,8 +3122,8 @@ pseudoop "proxy#"
 pseudoop   "seq"
    a -> b -> b
    { The value of {\tt seq a b} is bottom if {\tt a} is bottom, and
-     otherwise equal to {\tt b}. In other words, it evaluates the first 
-     argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually 
+     otherwise equal to {\tt b}. In other words, it evaluates the first
+     argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually
      introduced to improve performance by avoiding unneeded laziness.
 
      A note on evaluation order: the expression {\tt seq a b} does
index 1c92740..d1f87e1 100644 (file)
@@ -1388,19 +1388,10 @@ unIO (IO a) = a
 {- |
 Returns the tag of a constructor application; this function is used
 by the deriving code for Eq, Ord and Enum.
-
-The primitive dataToTag# requires an evaluated constructor application
-as its argument, so we provide getTag as a wrapper that performs the
-evaluation before calling dataToTag#.  We could have dataToTag#
-evaluate its argument, but we prefer to do it this way because (a)
-dataToTag# can be an inline primop if it doesn't need to do any
-evaluation, and (b) we want to expose the evaluation to the
-simplifier, because it might be possible to eliminate the evaluation
-in the case when the argument is already known to be evaluated.
 -}
 {-# INLINE getTag #-}
 getTag :: a -> Int#
-getTag !x = dataToTag# x
+getTag x = dataToTag# x
 
 ----------------------------------------------
 -- Numeric primops
index c94c8b6..a1fc58f 100644 (file)
@@ -5,9 +5,6 @@ include $(TOP)/mk/test.mk
 T2578:
        '$(TEST_HC)' $(TEST_HC_OPTS) --make T2578 -fforce-recomp -v0
 
-T14626:
-       '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-prep -dsuppress-uniques T14626.hs | grep case
-
 debug:
        # Without optimisations, we should get annotations for basically
        # all expressions in the example program.
diff --git a/testsuite/tests/codeGen/should_compile/T14626.hs b/testsuite/tests/codeGen/should_compile/T14626.hs
deleted file mode 100644 (file)
index a665694..0000000
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-
-module T14626 where
-
-import GHC.Prim
-
-data T = MkT !Bool
-
-f v = case v of
-         MkT y -> dataToTag# y
-
--- This should /not/ produce an inner case on the y, thus:
---    f v = case v of
---            MkT y -> case y of z -> dataToTag# z
--- But it was!  See Trac #14626 comment:4
index dd6931f..a5d5a47 100644 (file)
@@ -35,9 +35,6 @@ test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')),
      compile, ['-g'])
 test('T12115', normal, compile, [''])
 test('T12355', normal, compile, [''])
-test('T14626',
-     normal,
-     run_command, ['$MAKE -s --no-print-directory T14626'])
 test('T14999',
      [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261)),
       unless(opsys('linux') and arch('x86_64') and have_gdb() and
diff --git a/testsuite/tests/codeGen/should_run/T15696_1.hs b/testsuite/tests/codeGen/should_run/T15696_1.hs
new file mode 100644 (file)
index 0000000..e747c0a
--- /dev/null
@@ -0,0 +1,26 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts
+import GHC.Prim
+
+main :: IO ()
+main = print (cmpT a T2)
+  where
+    {-# NOINLINE f #-}
+    f = T2
+    {-# NOINLINE a #-}
+    a = f
+
+data T = T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9
+
+cmpT a b
+    = case dataToTag# a of
+        a' -> case dataToTag# b of
+                b' ->
+                      if tagToEnum# (a' <# b') :: Bool then
+                          LT -- used to return this
+                      else
+                          if tagToEnum# (a' ==# b') :: Bool then
+                              EQ -- should return this
+                          else
+                              GT
diff --git a/testsuite/tests/codeGen/should_run/T15696_1.stdout b/testsuite/tests/codeGen/should_run/T15696_1.stdout
new file mode 100644 (file)
index 0000000..03426a7
--- /dev/null
@@ -0,0 +1 @@
+EQ
diff --git a/testsuite/tests/codeGen/should_run/T15696_2.hs b/testsuite/tests/codeGen/should_run/T15696_2.hs
new file mode 100644 (file)
index 0000000..1a404be
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts
+import GHC.Prim
+
+main :: IO ()
+main = do
+    print (I# (dataToTag# a))  -- used to print 0, should print 1
+    print (I# (dataToTag# f))  -- used to print 1 correctly
+
+  where
+    {-# NOINLINE f #-}
+    f = T2
+    {-# NOINLINE a #-}
+    a = f
+
+data T = T1 | T2
diff --git a/testsuite/tests/codeGen/should_run/T15696_2.stdout b/testsuite/tests/codeGen/should_run/T15696_2.stdout
new file mode 100644 (file)
index 0000000..6ed281c
--- /dev/null
@@ -0,0 +1,2 @@
+1
+1
diff --git a/testsuite/tests/codeGen/should_run/T15696_3.hs b/testsuite/tests/codeGen/should_run/T15696_3.hs
new file mode 100644 (file)
index 0000000..73b7f3c
--- /dev/null
@@ -0,0 +1,9 @@
+import qualified Data.Set as S
+
+main = print $
+  let {-# noinline f #-}
+      f () = T2
+  in  S.fromList [f (), f ()]
+
+data T = T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9
+  deriving (Show, Read, Eq, Ord, Bounded, Enum)
diff --git a/testsuite/tests/codeGen/should_run/T15696_3.stdout b/testsuite/tests/codeGen/should_run/T15696_3.stdout
new file mode 100644 (file)
index 0000000..307f49a
--- /dev/null
@@ -0,0 +1 @@
+fromList [T2]
index bd1521d..eaf0e77 100644 (file)
@@ -172,4 +172,12 @@ test('T13825-unit',
 test('T14619', normal, compile_and_run, [''])
 test('T14754', normal, compile_and_run, [''])
 test('T14346', only_ways(['threaded1','threaded2']), compile_and_run, ['-O -threaded'])
-test('T14251', normal, compile_and_run, [''])
+test('T14251', [expect_broken_for(14251, [''])],
+     compile_and_run, [''])
+
+# These actually used to fail with all optimisation settings, but adding -O just
+# to make sure
+test('T15696_1', normal, compile_and_run, ['-O'])
+test('T15696_2', normal, compile_and_run, ['-O'])
+# This requires -O
+test('T15696_3', normal, compile_and_run, ['-O'])