summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/SimpleOpt.hs61
-rw-r--r--compiler/GHC/Core/Utils.hs17
-rw-r--r--compiler/GHC/Types/Id.hs2
-rw-r--r--compiler/GHC/Types/Id/Make.hs45
m---------libraries/parsec0
-rw-r--r--testsuite/tests/deSugar/should_compile/T2431.stderr5
-rw-r--r--testsuite/tests/simplCore/should_compile/T18013.stderr4
-rw-r--r--testsuite/tests/simplCore/should_compile/T7360.stderr2
-rw-r--r--testsuite/tests/simplCore/should_run/T18012.hs41
-rw-r--r--testsuite/tests/simplCore/should_run/T18012.stdout1
-rw-r--r--testsuite/tests/simplCore/should_run/all.T1
-rw-r--r--testsuite/tests/stranal/should_compile/T16029.stdout2
12 files changed, 162 insertions, 19 deletions
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 0728ea11c8..7545209b77 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -889,6 +889,10 @@ And now we have a known-constructor MkT that we can return.
Notice that both (2) and (3) require exprIsConApp_maybe to gather and return
a bunch of floats, both let and case bindings.
+Note that this strategy introduces some subtle scenarios where a data-con
+wrapper can be replaced by a data-con worker earlier than we’d like, see
+Note [exprIsConApp_maybe for data-con wrappers: tricky corner].
+
Note [beta-reduction in exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is
@@ -949,6 +953,60 @@ exprIsConApp_maybe does not return Just) then nothing happens, and nothing
will happen the next time either.
See test T16254, which checks the behavior of newtypes.
+
+Note [exprIsConApp_maybe for data-con wrappers: tricky corner]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking
+
+ * exprIsConApp_maybe honours the inline phase; that is, it does not look
+ inside the unfolding for an Id unless its unfolding is active in this phase.
+ That phase-sensitivity is expressed in the InScopeEnv (specifically, the
+ IdUnfoldingFun component of the InScopeEnv) passed to exprIsConApp_maybe.
+
+ * Data-constructor wrappers are active only in phase 0 (the last phase);
+ see Note [Activation for data constructor wrappers] in GHC.Types.Id.Make.
+
+On the face of it that means that exprIsConApp_maybe won't look inside data
+constructor wrappers until phase 0. But that seems pretty Bad. So we cheat.
+For data con wrappers we unconditionally look inside its unfolding, regardless
+of phase, so that we get case-of-known-constructor to fire in every phase.
+
+Perhaps unsurprisingly, this cheating can backfire. An example:
+
+ data T = C !A B
+ foo p q = let x = C e1 e2 in seq x $ f x
+ {-# RULE "wurble" f (C a b) = b #-}
+
+In Core, the RHS of foo is
+
+ let x = $WC e1 e2 in case x of y { C _ _ -> f x }
+
+and after doing a binder swap and inlining x, we have:
+
+ case $WC e1 e2 of y { C _ _ -> f y }
+
+Case-of-known-constructor fires, but now we have to reconstruct a binding for
+`y` (which was dead before the binder swap) on the RHS of the case alternative.
+Naturally, we’ll use the worker:
+
+ case e1 of a { DEFAULT -> let y = C a e2 in f y }
+
+and after inlining `y`, we have:
+
+ case e1 of a { DEFAULT -> f (C a e2) }
+
+Now we might hope the "wurble" rule would fire, but alas, it will not: we have
+replaced $WC with C, but the (desugared) rule matches on $WC! We weren’t
+supposed to inline $WC yet for precisely that reason (see Note [Activation for
+data constructor wrappers]), but our cheating in exprIsConApp_maybe came back to
+bite us.
+
+This is rather unfortunate, especially since this can happen inside stable
+unfoldings as well as ordinary code (which really happened, see !3041). But
+there is no obvious solution except to delay case-of-known-constructor on
+data-con wrappers, and that cure would be worse than the disease.
+
+This Note exists solely to document the problem.
-}
data ConCont = CC [CoreExpr] Coercion
@@ -1033,7 +1091,8 @@ exprIsConApp_maybe (in_scope, id_unf) expr
-- Look through data constructor wrappers: they inline late (See Note
-- [Activation for data constructor wrappers]) but we want to do
- -- case-of-known-constructor optimisation eagerly.
+ -- case-of-known-constructor optimisation eagerly (see Note
+ -- [exprIsConApp_maybe on data constructors with wrappers]).
| isDataConWrapId fun
, let rhs = uf_tmpl (realIdUnfolding fun)
= go (Left in_scope) floats rhs cont
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index a0704ef03a..d954374eef 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -91,7 +91,7 @@ import GHC.Builtin.Types.Prim
import FastString
import Maybes
import ListSetOps ( minusList )
-import GHC.Types.Basic ( Arity, isConLike )
+import GHC.Types.Basic ( Arity )
import Util
import Pair
import Data.ByteString ( ByteString )
@@ -1387,15 +1387,14 @@ isExpandableApp fn n_val_args
| isWorkFreeApp fn n_val_args = True
| otherwise
= case idDetails fn of
- DataConWorkId {} -> True -- Actually handled by isWorkFreeApp
- RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
- ClassOpId {} -> n_val_args == 1
- PrimOpId {} -> False
- _ | isBottomingId fn -> False
+ RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
+ ClassOpId {} -> n_val_args == 1
+ PrimOpId {} -> False
+ _ | isBottomingId fn -> False
-- See Note [isExpandableApp: bottoming functions]
- | isConLike (idRuleMatchInfo fn) -> True
- | all_args_are_preds -> True
- | otherwise -> False
+ | isConLikeId fn -> True
+ | all_args_are_preds -> True
+ | otherwise -> False
where
-- See if all the arguments are PredTys (implicit params or classes)
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index fab72d23de..713f1c6258 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -768,7 +768,7 @@ idRuleMatchInfo :: Id -> RuleMatchInfo
idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
isConLikeId :: Id -> Bool
-isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
+isConLikeId id = isConLike (idRuleMatchInfo id)
{-
---------------------------------
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index ce5012458a..d9d137a13b 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -510,19 +510,21 @@ mkDataConWorkId wkr_name data_con
alg_wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setCprInfo` mkCprSig wkr_arity (dataConCPR data_con)
+ `setInlinePragInfo` wkr_inline_prag
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setLevityInfoWithType` wkr_ty
-- NB: unboxed tuples have workers, so we can't use
-- setNeverLevPoly
+ wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike }
wkr_arity = dataConRepArity data_con
----------- Workers for newtypes --------------
univ_tvs = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
- `setInlinePragInfo` alwaysInlinePragma
+ `setInlinePragInfo` dataConWrapperInlinePragma
`setUnfoldingInfo` newtype_unf
`setLevityInfoWithType` wkr_ty
id_arg1 = mkTemplateLocal 1 (head arg_tys)
@@ -652,8 +654,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
mk_dmd str | isBanged str = evalDmd
| otherwise = topDmd
- wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
- activeDuringFinal
+ wrap_prag = dataConWrapperInlinePragma
+ `setInlinePragmaActivation` activeDuringFinal
-- See Note [Activation for data constructor wrappers]
-- The wrapper will usually be inlined (see wrap_unf), so its
@@ -763,6 +765,12 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
; return (unbox_fn expr) }
+
+dataConWrapperInlinePragma :: InlinePragma
+-- See Note [DataCon wrappers are conlike]
+dataConWrapperInlinePragma = alwaysInlinePragma { inl_rule = ConLike
+ , inl_inline = Inline }
+
{- Note [Activation for data constructor wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Activation on a data constructor wrapper allows it to inline only in Phase
@@ -784,6 +792,37 @@ the order of type argument could make previously working RULEs fail.
See also https://gitlab.haskell.org/ghc/ghc/issues/15840 .
+Note [DataCon wrappers are conlike]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DataCon workers are clearly ConLike --- they are the “Con” in
+“ConLike”, after all --- but what about DataCon wrappers? Should they
+be marked ConLike, too?
+
+Yes, absolutely! As described in Note [CONLIKE pragma] in
+GHC.Types.Basic, isConLike influences GHC.Core.Utils.exprIsExpandable,
+which is used by both RULE matching and the case-of-known-constructor
+optimization. It’s crucial that both of those things can see
+applications of DataCon wrappers:
+
+ * User-defined RULEs match on wrappers, not workers, so we might
+ need to look through an unfolding built from a DataCon wrapper to
+ determine if a RULE matches.
+
+ * Likewise, if we have something like
+ let x = $WC a b in ... case x of { C y z -> e } ...
+ we still want to apply case-of-known-constructor.
+
+Therefore, it’s important that we consider DataCon wrappers conlike.
+This is especially true now that we don’t inline DataCon wrappers
+until the final simplifier phase; see Note [Activation for data
+constructor wrappers].
+
+For further reading, see:
+ * Note [Conlike is interesting] in GHC.Core.Op.Simplify.Utils
+ * Note [Lone variables] in GHC.Core.Unfold
+ * Note [exprIsConApp_maybe on data constructors with wrappers]
+ in GHC.Core.SimpleOpt
+ * #18012
Note [Bangs on imported data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/parsec b/libraries/parsec
-Subproject ee741870f028e036ab15ae6e2183f09b31e51ae
+Subproject ce416997e15438ca616667995660e123ef7e219
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 608b26b793..08946c5cd3 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -4,7 +4,7 @@ Result size of Tidy Core
= {terms: 63, types: 43, coercions: 1, joins: 0/0}
-- RHS size: {terms: 2, types: 4, coercions: 1, joins: 0/0}
-T2431.$WRefl [InlPrag=INLINE[0]] :: forall a. a :~: a
+T2431.$WRefl [InlPrag=INLINE[0] CONLIKE] :: forall a. a :~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
Cpr=m1,
@@ -110,3 +110,6 @@ T2431.$tc'Refl
$tc'Refl2
1#
$krep3
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr
index 677c08e7d9..42f517b9ea 100644
--- a/testsuite/tests/simplCore/should_compile/T18013.stderr
+++ b/testsuite/tests/simplCore/should_compile/T18013.stderr
@@ -120,11 +120,11 @@ Rule fired: mkRule @(_, ()) (T18013a)
Rule fired: Class op fmap (BUILTIN)
Rule fired: mkRule @((), _) (T18013a)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @(_, ()) (T18013a)
+Rule fired: mkRule @((), _) (T18013a)
Rule fired: Class op fmap (BUILTIN)
Rule fired: mkRule @(_, ()) (T18013a)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
+Rule fired: mkRule @(_, ()) (T18013a)
Rule fired: Class op fmap (BUILTIN)
==================== Tidy Core ====================
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 45c88f376e..a5765d480a 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -4,7 +4,7 @@ Result size of Tidy Core
= {terms: 106, types: 47, coercions: 0, joins: 0/0}
-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
-T7360.$WFoo3 [InlPrag=INLINE[0]] :: Int -> Foo
+T7360.$WFoo3 [InlPrag=INLINE[0] CONLIKE] :: Int -> Foo
[GblId[DataConWrapper],
Arity=1,
Caf=NoCafRefs,
diff --git a/testsuite/tests/simplCore/should_run/T18012.hs b/testsuite/tests/simplCore/should_run/T18012.hs
new file mode 100644
index 0000000000..9118b75ff4
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18012.hs
@@ -0,0 +1,41 @@
+module Main (main) where
+
+{- This program is designed to check that case-of-known-constructor
+fires even if an application of a DataCon wrapper is floated out:
+
+ * The early FloatOut pass will float `D False` out of `g`, since
+ it’s a constant, non-trivial expression.
+
+ * But since `D` is strict, the floated-out expression will actually
+ be `$WD False`.
+
+ * In simplifier phase 2, `f` will be inlined into `g`, leading to a
+ case expression that scrutinizes the floated-out binding.
+
+ * If case-of-known-constructor fires, we’ll end up with `notRule
+ False`, the RULE will fire, and we get True.
+
+ * If it doesn’t fire at phase 2, it will fire later at phase 0 when
+ we inline the DataCon wrapper. But now the RULE is inactive, so
+ we’ll end up with False instead.
+
+We want case-of-known-constructor to fire early, so we want the output
+to be True. See #18012 for more details. -}
+
+main :: IO ()
+main = print (g ())
+
+data T = D !Bool
+
+notRule :: Bool -> Bool
+notRule x = x
+{-# INLINE [0] notRule #-}
+{-# RULES "notRule/False" [~0] notRule False = True #-}
+
+f :: T -> () -> Bool
+f (D a) () = notRule a
+{-# INLINE [100] f #-} -- so it isn’t inlined before FloatOut
+
+g :: () -> Bool
+g x = f (D False) x
+{-# NOINLINE g #-}
diff --git a/testsuite/tests/simplCore/should_run/T18012.stdout b/testsuite/tests/simplCore/should_run/T18012.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18012.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index d101bff84b..210949d9c6 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -93,3 +93,4 @@ test('T15840a', normal, compile_and_run, [''])
test('T16066', exit_code(1), compile_and_run, ['-O1'])
test('T17206', exit_code(1), compile_and_run, [''])
test('T17151', [], multimod_compile_and_run, ['T17151', ''])
+test('T18012', normal, compile_and_run, [''])
diff --git a/testsuite/tests/stranal/should_compile/T16029.stdout b/testsuite/tests/stranal/should_compile/T16029.stdout
index 5aae1ff281..26c2973852 100644
--- a/testsuite/tests/stranal/should_compile/T16029.stdout
+++ b/testsuite/tests/stranal/should_compile/T16029.stdout
@@ -1,4 +1,4 @@
-T16029.$WMkT [InlPrag=INLINE[0]] :: Int -> Int -> T
+T16029.$WMkT [InlPrag=INLINE[0] CONLIKE] :: Int -> Int -> T
Tmpl= \ (dt [Occ=Once!] :: Int) (dt [Occ=Once!] :: Int) ->
= \ (dt [Occ=Once!] :: Int) (dt [Occ=Once!] :: Int) ->
:: GHC.Prim.Int# -> GHC.Prim.Int#
View Lorry Controller Status