summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Core.hs10
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs226
-rw-r--r--compiler/GHC/Types/Tickish.hs4
-rw-r--r--testsuite/tests/profiling/should_compile/all.T2
4 files changed, 181 insertions, 61 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index cc7320f531..15a0674e38 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -47,7 +47,7 @@ module GHC.Core (
collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
exprToType, exprToCoercion_maybe,
- applyTypeToArg,
+ applyTypeToArg, wrapLamBody,
isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount,
isRuntimeArg, isRuntimeVar,
@@ -1942,6 +1942,14 @@ collectArgs expr
go (App f a) as = go f (a:as)
go e as = (e, as)
+-- | fmap on the body of a lambda.
+-- wrapLamBody f (\x -> body) == (\x -> f body)
+wrapLamBody :: (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
+wrapLamBody f expr = go expr
+ where
+ go (Lam v body) = Lam v $ go body
+ go expr = f expr
+
-- | Attempt to remove the last N arguments of a function call.
-- Strip off any ticks or coercions encountered along the way and any
-- at the end.
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 1e2748318a..afff96e6ed 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -792,7 +792,8 @@ cpeRhsE env (Let bind body)
; return (bind_floats `appendFloats` body_floats, expr') }
cpeRhsE env (Tick tickish expr)
- | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
+ -- Pull out ticks if they are allowed to be floated.
+ | floatableTick tickish
= do { (floats, body) <- cpeRhsE env expr
-- See [Floating Ticks in CorePrep]
; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
@@ -946,11 +947,50 @@ instance Outputable ArgInfo where
ppr (CpeCast co) = text "cast" <+> ppr co
ppr (CpeTick tick) = text "tick" <+> ppr tick
+{- Note [Ticks and mandatory eta expansion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Something like
+ `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`
+caused a compiler panic in #20938. Why did this happen?
+The simplifier will eta-reduce the rhs giving us a partial
+application of tagToEnum#. The tick is then pushed inside the
+type argument. That is we get
+ `(Tick<foo> tagToEnum#) @Bool`
+CorePrep would go on to see a undersaturated tagToEnum# application
+and eta expand the expression under the tick. Giving us:
+ (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool
+Suddenly tagToEnum# is applied to a polymorphic type and the code generator
+panics as it needs a concrete type to determine the representation.
+
+The problem in my eyes was that the tick covers a partial application
+of a primop. There is no clear semantic for such a construct as we can't
+partially apply a primop since they do not have bindings.
+We fix this by expanding the scope of such ticks slightly to cover the body
+of the eta-expanded expression.
+
+We do this by:
+* Checking if an application is headed by a primOpish thing.
+* If so we collect floatable ticks and usually but also profiling ticks
+ along with regular arguments.
+* When rebuilding the application we check if any profiling ticks appear
+ before the primop is fully saturated.
+* If the primop isn't fully satured we eta expand the primop application
+ and scope the tick to scope over the body of the saturated expression.
+
+Going back to #20938 this means starting with
+ `(Tick<foo> tagToEnum#) @Bool`
+we check if the function head is a primop (yes). This means we collect the
+profiling tick like if it was floatable. Giving us
+ (tagToEnum#, [CpeTick foo, CpeApp @Bool]).
+cpe_app filters out the tick as a underscoped tick on the expression
+`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the
+body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
+-}
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- May return a CpeRhs because of saturating primops
cpeApp top_env expr
- = do { let (terminal, args, depth) = collect_args expr
- ; cpe_app top_env terminal args depth
+ = do { let (terminal, args) = collect_args expr
+ ; cpe_app top_env terminal args
}
where
@@ -961,26 +1001,34 @@ cpeApp top_env expr
-- record casts and ticks. Depth counts the number
-- of arguments that would consume strictness information
-- (so, no type or coercion arguments.)
- collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
- collect_args e = go e [] 0
+ collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])
+ collect_args e = go e []
where
- go (App fun arg) as !depth
+ go (App fun arg) as
= go fun (CpeApp arg : as)
- (if isTyCoArg arg then depth else depth + 1)
- go (Cast fun co) as depth
- = go fun (CpeCast co : as) depth
- go (Tick tickish fun) as depth
- | tickishPlace tickish == PlaceNonLam
- && tickish `tickishScopesLike` SoftScope
- = go fun (CpeTick tickish : as) depth
- go terminal as depth = (terminal, as, depth)
+ go (Cast fun co) as
+ = go fun (CpeCast co : as)
+ go (Tick tickish fun) as
+ -- Profiling ticks are slightly less strict so we expand their scope
+ -- if they cover partial applications of things like primOps.
+ -- See Note [Ticks and mandatory eta expansion]
+ | floatableTick tickish || isProfTick tickish
+ , Var vh <- head
+ , Var head' <- lookupCorePrepEnv top_env vh
+ , hasNoBinding head'
+ = (head,as')
+ where
+ (head,as') = go fun (CpeTick tickish : as)
+
+ -- Terminal could still be an app if it's wrapped by a tick.
+ -- E.g. Tick<foo> (f x) can give us (f x) as terminal.
+ go terminal as = (terminal, as)
cpe_app :: CorePrepEnv
-> CoreExpr
-> [ArgInfo]
- -> Int
-> UniqSM (Floats, CpeRhs)
- cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
+ cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)
| f `hasKey` lazyIdKey -- Replace (lazy a) with a, and
-- See Note [lazyId magic] in GHC.Types.Id.Make
|| f `hasKey` noinlineIdKey -- Replace (noinline a) with a
@@ -999,14 +1047,13 @@ cpeApp top_env expr
-- }
--
-- rather than the far superior "f x y". Test case is par01.
- = let (terminal, args', depth') = collect_args arg
- in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
+ = let (terminal, args') = collect_args arg
+ in cpe_app env terminal (args' ++ args)
-- See Note [keepAlive# magic].
cpe_app env
(Var f)
args
- n
| Just KeepAliveOp <- isPrimOpId_maybe f
, CpeApp (Type arg_rep)
: CpeApp (Type arg_ty)
@@ -1020,8 +1067,8 @@ cpeApp top_env expr
; s2 <- newVar realWorldStatePrimTy
; -- beta reduce if possible
; (floats, k') <- case k of
- Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2)
- _ -> cpe_app env k (CpeApp s0 : rest) (n-1)
+ Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest
+ _ -> cpe_app env k (CpeApp s0 : rest)
; let touchId = primOpId TouchOp
expr = Case k' y result_ty [Alt DEFAULT [] rhs]
rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId]
@@ -1032,31 +1079,37 @@ cpeApp top_env expr
| Just KeepAliveOp <- isPrimOpId_maybe f
= panic "invalid keepAlive# application"
- cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n
+ -- runRW# magic
+ cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)
| f `hasKey` runRWKey
-- N.B. While it may appear that n == 1 in the case of runRW#
-- applications, keep in mind that we may have applications that return
- , n >= 1
+ , has_value_arg (CpeApp arg : rest)
-- See Note [runRW magic]
-- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
-- is why we return a CorePrepEnv as well)
= case arg of
- Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2)
- _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1)
+ Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest
+ _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest)
-- TODO: What about casts?
+ where
+ has_value_arg [] = False
+ has_value_arg (CpeApp arg:_rest)
+ | not (isTyCoArg arg) = True
+ has_value_arg (_:rest) = has_value_arg rest
- cpe_app env (Var v) args depth
+ cpe_app env (Var v) args
= do { v1 <- fiddleCCall v
; let e2 = lookupCorePrepEnv env v1
hd = getIdFromTrivialExpr_maybe e2
- -- NB: depth from collect_args is right, because e2 is a trivial expression
- -- and thus its embedded Id *must* be at the same depth as any
- -- Apps it is under are type applications only (c.f.
- -- exprIsTrivial). But note that we need the type of the
- -- expression, not the id.
- ; (app, floats) <- rebuild_app env args e2 emptyFloats stricts
- ; mb_saturate hd app floats depth }
+ -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
+ min_arity = case hd of
+ Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing
+ Nothing -> Nothing
+ ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
+ ; mb_saturate hd app floats unsat_ticks depth }
where
+ depth = val_args args
stricts = case idDmdSig v of
DmdSig (DmdType _ demands _)
| listLengthCmp demands depth /= GT -> demands
@@ -1070,22 +1123,45 @@ cpeApp top_env expr
-- We inlined into something that's not a var and has no args.
-- Bounce it back up to cpeRhsE.
- cpe_app env fun [] _ = cpeRhsE env fun
+ cpe_app env fun [] = cpeRhsE env fun
- -- N-variable fun, better let-bind it
- cpe_app env fun args depth
+ -- Here we get:
+ -- N-variable fun, better let-bind it
+ -- This case covers literals, apps, lams or let expressions applied to arguments.
+ -- Basically things we want to ANF before applying to arguments.
+ cpe_app env fun args
= do { (fun_floats, fun') <- cpeArg env evalDmd fun
- -- The evalDmd says that it's sure to be evaluated,
- -- so we'll end up case-binding it
- ; (app, floats) <- rebuild_app env args fun' fun_floats []
- ; mb_saturate Nothing app floats depth }
+ -- If evalDmd says that it's sure to be evaluated,
+ -- we'll end up case-binding it
+ ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing
+ ; mb_saturate Nothing app floats unsat_ticks (val_args args) }
+
+ -- | Count the number of value arguments.
+ val_args :: [ArgInfo] -> Int
+ val_args args = go args 0
+ where
+ go [] !n = n
+ go (info:infos) n =
+ case info of
+ CpeCast {} -> go infos n
+ CpeTick tickish
+ | floatableTick tickish -> go infos n
+ -- If we can't guarantee a tick will be floated out of the application
+ -- we can't guarantee the value args following it will be applied.
+ | otherwise -> n
+ CpeApp e -> go infos n'
+ where
+ !n'
+ | isTyCoArg e = n
+ | otherwise = n+1
-- Saturate if necessary
- mb_saturate head app floats depth =
+ mb_saturate head app floats unsat_ticks depth =
case head of
- Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
+ Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks
; return (floats, sat_app) }
- _other -> return (floats, app)
+ _other -> do { massert (null unsat_ticks)
+ ; return (floats, app) }
-- Deconstruct and rebuild the application, floating any non-atomic
-- arguments to the outside. We collect the type of the expression,
@@ -1098,20 +1174,43 @@ cpeApp top_env expr
-> CpeApp
-> Floats
-> [Demand]
- -> UniqSM (CpeApp, Floats)
- rebuild_app _ [] app floats ss
+ -> Maybe Arity
+ -> UniqSM (CpeApp
+ ,Floats
+ ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]
+ )
+ rebuild_app env args app floats ss req_depth =
+ rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth)
+
+ rebuild_app'
+ :: CorePrepEnv
+ -> [ArgInfo] -- The arguments (inner to outer)
+ -> CpeApp
+ -> Floats
+ -> [Demand]
+ -> [CoreTickish]
+ -> Int -- Number of arguments required to satisfy minimal tick scopes.
+ -> UniqSM (CpeApp, Floats, [CoreTickish])
+ rebuild_app' _ [] app floats ss rt_ticks !_req_depth
= assert (null ss) -- make sure we used all the strictness info
- return (app, floats)
+ return (app, floats, rt_ticks)
- rebuild_app env (a : as) fun' floats ss = case a of
+ rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of
+ -- See Note [Ticks and mandatory eta expansion]
+ _
+ | not (null rt_ticks)
+ , req_depth <= 0
+ ->
+ let tick_fun = foldr mkTick fun' rt_ticks
+ in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth
CpeApp (Type arg_ty)
- -> rebuild_app env as (App fun' (Type arg_ty')) floats ss
+ -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth
where
arg_ty' = cpSubstTy env arg_ty
CpeApp (Coercion co)
- -> rebuild_app env as (App fun' (Coercion co')) floats ss
+ -> rebuild_app' env as (App fun' (Coercion co')) floats ss rt_ticks req_depth
where
co' = cpSubstCo env co
@@ -1122,16 +1221,21 @@ cpeApp top_env expr
(ss1 : ss_rest, False) -> (ss1, ss_rest)
([], _) -> (topDmd, [])
(fs, arg') <- cpeArg top_env ss1 arg
- rebuild_app env as (App fun' arg') (fs `appendFloats` floats) ss_rest
+ rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1)
CpeCast co
- -> rebuild_app env as (Cast fun' co') floats ss
+ -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth
where
co' = cpSubstCo env co
-
+ -- See Note [Ticks and mandatory eta expansion]
CpeTick tickish
+ | tickishPlace tickish == PlaceRuntime
+ , req_depth > 0
+ -> assert (isProfTick tickish) $
+ rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth
+ | otherwise
-- See [Floating Ticks in CorePrep]
- -> rebuild_app env as fun' (addFloat floats (FloatTick tickish)) ss
+ -> rebuild_app' env as fun' (addFloat floats (FloatTick tickish)) ss rt_ticks req_depth
isLazyExpr :: CoreExpr -> Bool
-- See Note [lazyId magic] in GHC.Types.Id.Make
@@ -1425,13 +1529,14 @@ applications here as well but due to this fragility (see #16846) we now deal
with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps.
-}
-maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
-maybeSaturate fn expr n_args
+maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
+maybeSaturate fn expr n_args unsat_ticks
| hasNoBinding fn -- There's no binding
- = return sat_expr
+ = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr
| otherwise
- = return expr
+ = assert (null unsat_ticks) $
+ return expr
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
@@ -1452,7 +1557,7 @@ maybeSaturate fn expr n_args
Note [Eta expansion]
~~~~~~~~~~~~~~~~~~~~~
-Eta expand to match the arity claimed by the binder. Remember,
+Eta expand to match the arity claimed by the binder Remember,
CorePrep must not change arity
Eta expansion might not have happened already, because it is done by
@@ -2118,7 +2223,10 @@ wrapTicks (Floats flag floats0) expr =
wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)
-
+floatableTick :: GenTickish pass -> Bool
+floatableTick tickish =
+ tickishPlace tickish == PlaceNonLam &&
+ tickish `tickishScopesLike` SoftScope
------------------------------------------------------------------------------
-- Numeric literals
diff --git a/compiler/GHC/Types/Tickish.hs b/compiler/GHC/Types/Tickish.hs
index b7d28c01d8..30827bb1fb 100644
--- a/compiler/GHC/Types/Tickish.hs
+++ b/compiler/GHC/Types/Tickish.hs
@@ -18,6 +18,7 @@ module GHC.Types.Tickish (
mkNoCount,
mkNoScope,
tickishIsCode,
+ isProfTick,
TickishPlacement(..),
tickishPlace,
tickishContains
@@ -317,6 +318,9 @@ tickishIsCode :: GenTickish pass -> Bool
tickishIsCode SourceNote{} = False
tickishIsCode _tickish = True -- all the rest for now
+isProfTick :: GenTickish pass -> Bool
+isProfTick ProfNote{} = True
+isProfTick _ = False
-- | Governs the kind of expression that the tick gets placed on when
-- annotating for example using @mkTick@. If we find that we want to
diff --git a/testsuite/tests/profiling/should_compile/all.T b/testsuite/tests/profiling/should_compile/all.T
index a19a2fc49a..de565de40b 100644
--- a/testsuite/tests/profiling/should_compile/all.T
+++ b/testsuite/tests/profiling/should_compile/all.T
@@ -10,4 +10,4 @@ test('T14931', [only_ways(['normal']), req_profiling, unless(have_dynamic(), ski
makefile_test, ['T14931'])
test('T15108', [only_ways(['normal']), req_profiling], compile, ['-O -prof -fprof-auto'])
test('T19894', [only_ways(['normal']), req_profiling, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894'])
-test('T20938', [only_ways(['normal']), req_profiling, expect_broken(20938)], compile, ['-O -prof'])
+test('T20938', [only_ways(['normal']), req_profiling], compile, ['-O -prof'])