diff options
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 12 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 6 | ||||
| -rw-r--r-- | compiler/coreSyn/CorePrep.hs | 71 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 17 | ||||
| -rw-r--r-- | compiler/prelude/PrelRules.hs | 13 | ||||
| -rw-r--r-- | compiler/prelude/PrimOp.hs | 1 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 44 | ||||
| -rw-r--r-- | libraries/base/GHC/Base.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_compile/Makefile | 3 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_compile/T14626.hs | 15 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_compile/all.T | 3 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/T15696_1.hs | 26 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/T15696_1.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/T15696_2.hs | 17 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/T15696_2.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/T15696_3.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/T15696_3.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/all.T | 10 |
18 files changed, 102 insertions, 160 deletions
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 22fcfaf412..1af8fb3376 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -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 diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index f5437c0c3b..c90264f14f 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -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, 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 diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index e94490007f..28c0628f16 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -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 diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index 4eb94e9fdb..369f17f7f5 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -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 diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 7360ccb758..303c902c83 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -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 diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 1c927405ce..d1f87e1d62 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -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 diff --git a/testsuite/tests/codeGen/should_compile/Makefile b/testsuite/tests/codeGen/should_compile/Makefile index c94c8b6f92..a1fc58f89b 100644 --- a/testsuite/tests/codeGen/should_compile/Makefile +++ b/testsuite/tests/codeGen/should_compile/Makefile @@ -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 index a665694bfc..0000000000 --- a/testsuite/tests/codeGen/should_compile/T14626.hs +++ /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 diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T index dd6931f235..a5d5a47034 100644 --- a/testsuite/tests/codeGen/should_compile/all.T +++ b/testsuite/tests/codeGen/should_compile/all.T @@ -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 index 0000000000..e747c0ad16 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15696_1.hs @@ -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 index 0000000000..03426a729d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15696_1.stdout @@ -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 index 0000000000..1a404bee92 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15696_2.hs @@ -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 index 0000000000..6ed281c757 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15696_2.stdout @@ -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 index 0000000000..73b7f3cde6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15696_3.hs @@ -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 index 0000000000..307f49a11a --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15696_3.stdout @@ -0,0 +1 @@ +fromList [T2] diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index bd1521d6d8..eaf0e77b97 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -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']) |