[Git][ghc/ghc][wip/runRW] 4 commits: CoreToStg: Add Outputable ArgInfo instance
Ben Gamari
gitlab at gitlab.haskell.org
Fri Apr 24 20:16:46 UTC 2020
Ben Gamari pushed to branch wip/runRW at Glasgow Haskell Compiler / GHC
Commits:
306dba47 by Ben Gamari at 2020-04-24T16:16:37-04:00
CoreToStg: Add Outputable ArgInfo instance
- - - - -
b9eebc84 by Simon Peyton Jones at 2020-04-24T16:16:37-04:00
Make Lint check return type of a join point
Consider
join x = rhs in body
It's important that the type of 'rhs' is the same as the type of
'body', but Lint wasn't checking that invariant.
Now it does! This was exposed by investigation into !3113.
- - - - -
891fc8b2 by Simon Peyton Jones at 2020-04-24T16:16:37-04:00
Do not float join points in exprIsConApp_maybe
We hvae been making exprIsConApp_maybe cleverer in recent times:
commit b78cc64e923716ac0512c299f42d4d0012306c05
Date: Thu Nov 15 17:14:31 2018 +0100
Make constructor wrappers inline only during the final phase
commit 7833cf407d1f608bebb1d38bb99d3035d8d735e6
Date: Thu Jan 24 17:58:50 2019 +0100
Look through newtype wrappers (Trac #16254)
commit c25b135ff5b9c69a90df0ccf51b04952c2dc6ee1
Date: Thu Feb 21 12:03:22 2019 +0000
Fix exprIsConApp_maybe
But alas there was still a bug, now immortalised in
Note [Don't float join points]
in SimpleOpt.
It's quite hard to trigger because it requires a dead
join point, but it came up when compiling Cabal
Cabal.Distribution.Fields.Lexer.hs, when working on
!3113.
Happily, the fix is extremly easy. Finding the
bug was not so easy.
- - - - -
8d548e83 by Ben Gamari at 2020-04-24T16:16:37-04:00
Allow simplification through runRW#
Because runRW# inlines so late, we were previously able to do very
little simplification across it. For instance, given even a simple
program like
case runRW# (\s -> let n = I# 42# in n) of
I# n# -> f n#
we previously had no way to avoid the allocation of the I#.
This patch allows the simplifier to push strict contexts into the
continuation of a runRW# application, as explained in
in Note [Simplification of runRW#] in GHC.CoreToStg.Prep.
Fixes #15127.
Co-Authored-By: Simon Peyton-Jone <simonpj at microsoft.com>
- - - - -
7 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/HsToCore/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -461,7 +461,7 @@ lintCoreBindings dflags pass local_in_scope binds
addLoc TopLevelBindings $
do { checkL (null dups) (dupVars dups)
; checkL (null ext_dups) (dupExtVars ext_dups)
- ; lintRecBindings TopLevel all_pairs $
+ ; lintRecBindings TopLevel all_pairs $ \_ ->
return () }
where
all_pairs = flattenBinds binds
@@ -572,11 +572,11 @@ Check a core binding, returning the list of variables bound.
-}
lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
- -> LintM a -> LintM a
+ -> ([LintedId] -> LintM a) -> LintM a
lintRecBindings top_lvl pairs thing_inside
= lintIdBndrs top_lvl bndrs $ \ bndrs' ->
do { zipWithM_ lint_pair bndrs' rhss
- ; thing_inside }
+ ; thing_inside bndrs' }
where
(bndrs, rhss) = unzip pairs
lint_pair bndr' rhs
@@ -584,6 +584,12 @@ lintRecBindings top_lvl pairs thing_inside
do { rhs_ty <- lintRhs bndr' rhs -- Check the rhs
; lintLetBind top_lvl Recursive bndr' rhs rhs_ty }
+lintLetBody :: [LintedId] -> CoreExpr -> LintM LintedType
+lintLetBody bndrs body
+ = do { body_ty <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
+ ; mapM_ (lintJoinBndrType body_ty) bndrs
+ ; return body_ty }
+
lintLetBind :: TopLevelFlag -> RecFlag -> LintedId
-> CoreExpr -> LintedType -> LintM ()
-- Binder's type, and the RHS, have already been linted
@@ -678,22 +684,9 @@ lintRhs :: Id -> CoreExpr -> LintM LintedType
-- its OccInfo and join-pointer-hood
lintRhs bndr rhs
| Just arity <- isJoinId_maybe bndr
- = lint_join_lams arity arity True rhs
+ = lintJoinLams arity (Just bndr) rhs
| AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
- = lint_join_lams arity arity False rhs
- where
- lint_join_lams 0 _ _ rhs
- = lintCoreExpr rhs
-
- lint_join_lams n tot enforce (Lam var expr)
- = lintLambda var $ lint_join_lams (n-1) tot enforce expr
-
- lint_join_lams n tot True _other
- = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs
- lint_join_lams _ _ False rhs
- = markAllJoinsBad $ lintCoreExpr rhs
- -- Future join point, not yet eta-expanded
- -- Body is not a tail position
+ = lintJoinLams arity Nothing rhs
-- Allow applications of the data constructor @StaticPtr@ at the top
-- but produce errors otherwise.
@@ -715,6 +708,22 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
binders0
go _ = markAllJoinsBad $ lintCoreExpr rhs
+-- | Lint the RHS of a join point with expected join arity of @n@ (see Note
+-- [Join points] in GHC.Core).
+lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM LintedType
+lintJoinLams join_arity enforce rhs
+ = go join_arity rhs
+ where
+ go 0 rhs = lintCoreExpr rhs
+ go n (Lam var expr) = lintLambda var $ go (n-1) expr
+ -- N.B. join points can be cast. e.g. we consider ((\x -> ...) `cast` ...)
+ -- to be a join point at join arity 1.
+ go n _other | Just bndr <- enforce -- Join point with too few RHS lambdas
+ = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs
+ | otherwise -- Future join point, not yet eta-expanded
+ = markAllJoinsBad $ lintCoreExpr rhs
+ -- Body of lambda is not a tail position
+
lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
lintIdUnfolding bndr bndr_ty uf
| isStableUnfolding uf
@@ -755,6 +764,40 @@ we will check any unfolding after it has been unfolded; checking the
unfolding beforehand is merely an optimization, and one that actively
hurts us here.
+Note [Linting of runRW#]
+~~~~~~~~~~~~~~~~~~~~~~~~
+runRW# has some very peculiar behavior (see Note [runRW magic] in
+GHC.CoreToStg.Prep) which CoreLint must accommodate.
+
+As described in Note [Casts and lambdas] in
+GHC.Core.Opt.Simplify.Utils, the simplifier pushes casts out of
+lambdas. Concretely, the simplifier will transform
+
+ runRW# @r @ty (\s -> expr `cast` co)
+
+into
+
+ runRW# @r @ty ((\s -> expr) `cast` co)
+
+Consequently we need to handle the case that the continuation is a
+cast of a lambda. See Note [Casts and lambdas] in
+GHC.Core.Opt.Simplify.Utils.
+
+In the event that the continuation is headed by a lambda (which
+will bind the State# token) we can safely allow calls to join
+points since CorePrep is going to apply the continuation to
+RealWorld.
+
+In the case that the continuation is not a lambda we lint the
+continuation disallowing join points, to rule out things like,
+
+ join j = ...
+ in runRW# @r @ty (
+ let x = jump j
+ in x
+ )
+
+
************************************************************************
* *
\subsection[lintCoreExpr]{lintCoreExpr}
@@ -769,6 +812,18 @@ type LintedCoercion = Coercion
type LintedTyCoVar = TyCoVar
type LintedId = Id
+-- | Lint an expression cast through the given coercion, returning the type
+-- resulting from the cast.
+lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType
+lintCastExpr expr expr_ty co
+ = do { co' <- lintCoercion co
+ ; let (Pair from_ty to_ty, role) = coercionKindRole co'
+ ; checkValueType to_ty $
+ text "target of cast" <+> quotes (ppr co')
+ ; lintRole co' Representational role
+ ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
+ ; return to_ty }
+
lintCoreExpr :: CoreExpr -> LintM LintedType
-- The returned type has the substitution from the monad
-- already applied to it:
@@ -786,14 +841,8 @@ lintCoreExpr (Lit lit)
= return (literalType lit)
lintCoreExpr (Cast expr co)
- = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
- ; co' <- lintCoercion co
- ; let (Pair from_ty to_ty, role) = coercionKindRole co'
- ; checkValueType to_ty $
- text "target of cast" <+> quotes (ppr co')
- ; lintRole co' Representational role
- ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
- ; return to_ty }
+ = do expr_ty <- markAllJoinsBad $ lintCoreExpr expr
+ lintCastExpr expr expr_ty co
lintCoreExpr (Tick tickish expr)
= do case tickish of
@@ -830,7 +879,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body)
-- Now lint the binder
; lintBinder LetBind bndr $ \bndr' ->
do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty
- ; addLoc (BodyOfLetRec [bndr]) (lintCoreExpr body) } }
+ ; lintLetBody [bndr'] body } }
| otherwise
= failWithL (mkLetErr bndr rhs) -- Not quite accurate
@@ -847,13 +896,37 @@ lintCoreExpr e@(Let (Rec pairs) body)
; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $
mkInconsistentRecMsg bndrs
- ; lintRecBindings NotTopLevel pairs $
- addLoc (BodyOfLetRec bndrs) $
- lintCoreExpr body }
+ ; lintRecBindings NotTopLevel pairs $ \ bndrs' ->
+ lintLetBody bndrs' body }
where
bndrs = map fst pairs
lintCoreExpr e@(App _ _)
+ | Var fun <- fun
+ , fun `hasKey` runRWKey
+ -- N.B. we may have an over-saturated application of the form:
+ -- runRW (\s -> \x -> ...) y
+ , arg_ty1 : arg_ty2 : arg3 : rest <- args
+ = do { fun_ty1 <- lintCoreArg (idType fun) arg_ty1
+ ; fun_ty2 <- lintCoreArg fun_ty1 arg_ty2
+ -- See Note [Linting of runRW#]
+ ; let lintRunRWCont :: CoreArg -> LintM LintedType
+ lintRunRWCont (Cast expr co) = do
+ ty <- lintRunRWCont expr
+ lintCastExpr expr ty co
+ lintRunRWCont expr@(Lam _ _) = do
+ lintJoinLams 1 (Just fun) expr
+ lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other
+ -- TODO: Look through ticks?
+ ; arg3_ty <- lintRunRWCont arg3
+ ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty
+ ; lintCoreArgs app_ty rest }
+
+ | Var fun <- fun
+ , fun `hasKey` runRWKey
+ = failWithL (text "Invalid runRW# application")
+
+ | otherwise
= do { fun_ty <- lintCoreFun fun (length args)
; lintCoreArgs fun_ty args }
where
@@ -950,6 +1023,25 @@ checkDeadIdOcc id
= return ()
------------------
+lintJoinBndrType :: LintedType -- Type of the body
+ -> LintedId -- Possibly a join Id
+ -> LintM ()
+-- Checks that the return type of a join Id matches the body
+-- E.g. join j x = rhs in body
+-- The type of 'rhs' must be the same as the type of 'body'
+lintJoinBndrType body_ty bndr
+ | Just arity <- isJoinId_maybe bndr
+ , let bndr_ty = idType bndr
+ , (bndrs, res) <- splitPiTys bndr_ty
+ = checkL (length bndrs >= arity
+ && body_ty `eqType` mkPiTys (drop arity bndrs) res) $
+ hang (text "Join point returns different type than body")
+ 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
+ , text "Join arity:" <+> ppr arity
+ , text "Body type:" <+> ppr body_ty ])
+ | otherwise
+ = return ()
+
checkJoinOcc :: Id -> JoinArity -> LintM ()
-- Check that if the occurrence is a JoinId, then so is the
-- binding site, and it's a valid join Id
@@ -1114,11 +1206,15 @@ lintTyApp fun_ty arg_ty
= failWithL (mkTyAppMsg fun_ty arg_ty)
-----------------
+
+-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@
+-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the
+-- application.
lintValApp :: CoreExpr -> LintedType -> LintedType -> LintM LintedType
lintValApp arg fun_ty arg_ty
- | Just (arg,res) <- splitFunTy_maybe fun_ty
- = do { ensureEqTys arg arg_ty err1
- ; return res }
+ | Just (arg_ty', res_ty') <- splitFunTy_maybe fun_ty
+ = do { ensureEqTys arg_ty' arg_ty err1
+ ; return res_ty' }
| otherwise
= failWithL err2
where
@@ -2751,11 +2847,11 @@ mkInvalidJoinPointMsg var ty
2 (ppr var <+> dcolon <+> ppr ty)
mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
-mkBadJoinArityMsg var ar nlams rhs
+mkBadJoinArityMsg var ar n rhs
= vcat [ text "Join point has too few lambdas",
text "Join var:" <+> ppr var,
text "Join arity:" <+> ppr ar,
- text "Number of lambdas:" <+> ppr nlams,
+ text "Number of lambdas:" <+> ppr (ar - n),
text "Rhs = " <+> ppr rhs
]
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -39,6 +39,7 @@ import GHC.Types.Demand ( argOneShots, argsOneShots )
import Digraph ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
+import GHC.Builtin.Names( runRWKey )
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
@@ -1882,8 +1883,15 @@ occAnalApp :: OccEnv
-> (UsageDetails, Expr CoreBndr)
-- Naked variables (not applied) end up here too
occAnalApp env (Var fun, args, ticks)
- | null ticks = (all_uds, mkApps fun' args')
- | otherwise = (all_uds, mkTicks ticks $ mkApps fun' args')
+ -- Account for join arity of runRW# continuation
+ -- See Note [Simplification of runRW#]
+ | fun `hasKey` runRWKey
+ , [t1, t2, arg] <- args
+ , let (usage, arg') = occAnalRhs env (Just 1) arg
+ = (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
+
+ | otherwise
+ = (all_uds, mkTicks ticks $ mkApps fun' args')
where
(fun', fun_id') = lookupVarEnv (occ_bs_env env) fun
`orElse` (Var fun, fun)
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1,7 +1,7 @@
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-\section{GHC.Core.Opt.SetLevels}
+\section{GHC.Core.Op.SetLevels}
***************************
Overview
@@ -91,12 +91,14 @@ import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig,
import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Types.Name ( getOccName, mkSystemVarName )
import GHC.Types.Name.Occurrence ( occNameString )
+import GHC.Types.Unique ( hasKey )
import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType
, mightBeUnliftedType, closeOverKindsDSet )
import GHC.Types.Basic ( Arity, RecFlag(..), isRec )
import GHC.Core.DataCon ( dataConOrigResTy )
import GHC.Builtin.Types
import GHC.Types.Unique.Supply
+import GHC.Builtin.Names ( runRWKey )
import Util
import Outputable
import FastString
@@ -399,8 +401,14 @@ lvlNonTailExpr env expr
lvlApp :: LevelEnv
-> CoreExprWithFVs
-> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
- -> LvlM LevelledExpr -- Result expression
+ -> LvlM LevelledExpr -- Result expression
lvlApp env orig_expr ((_,AnnVar fn), args)
+ -- Try to ensure that runRW#'s continuation isn't floated out.
+ -- See Note [Simplification of runRW#].
+ | fn `hasKey` runRWKey
+ = do { args' <- mapM (lvlExpr env) args
+ ; return (foldl' App (lookupVar env fn) args') }
+
| floatOverSat env -- See Note [Floating over-saturated applications]
, arity > 0
, arity < n_val_args
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -37,10 +37,13 @@ import GHC.Core.DataCon
, StrictnessMark (..) )
import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core
+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
+import GHC.Builtin.Names( runRWKey )
import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd
, mkClosedStrictSig, topDmd, botDiv )
import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Core.Ppr ( pprCoreExpr )
+import GHC.Types.Unique ( hasKey )
import GHC.Core.Unfold
import GHC.Core.Utils
import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg
@@ -1877,14 +1880,36 @@ rebuildCall env info (CastIt co cont)
rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
= rebuildCall env (addTyArgTo info arg_ty) cont
-rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
+---------- The runRW# rule. Do this after absorbing all arguments ------
+-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
+-- K[ runRW# rr ty (\s. body) ] --> runRW rr' ty' (\s. K[ body ])
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })
+ (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont })
+ | fun `hasKey` runRWKey
+ , not (contIsStop cont) -- Don't fiddle around if the continuation is boring
+ , [ TyArg {}, TyArg {} ] <- rev_args
+ = do { s <- newId (fsLit "s") realWorldStatePrimTy
+ ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
+ , sc_env = env', sc_cont = cont }
+ ; body' <- simplExprC env' arg cont'
+ ; let arg' = Lam s body'
+ ty' = contResultType cont
+ rr' = getRuntimeRep ty'
+ call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg']
+ ; return (emptyFloats env, call') }
+
+rebuildCall env info@(ArgInfo { ai_type = fun_ty, ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_cont = cont })
+
+ -- Argument is already simplified
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
= rebuildCall env (addValArgTo info' arg) cont
- | str -- Strict argument
+ -- Strict arguments
+ | str
, sm_case_case (getMode env)
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setInScopeFromE` env) arg
@@ -1892,7 +1917,8 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
, sc_dup = Simplified, sc_cont = cont })
-- Note [Shadowing]
- | otherwise -- Lazy argument
+ -- Lazy arguments
+ | otherwise
-- DO NOT float anything outside, hence simplExprC
-- There is no benefit (unlike in a let-binding), and we'd
-- have to be very careful about bogus strictness through
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -954,6 +954,31 @@ will happen the next time either.
See test T16254, which checks the behavior of newtypes.
+Note [Don't float join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsConApp_maybe should succeed on
+ let v = e in Just v
+returning [x=e] as one of the [FloatBind]. But it must
+NOT succeed on
+ join j x = rhs in Just v
+because join-points can't be gaily floated. Consider
+ case (join j x = rhs in Just) of
+ K p q -> blah
+We absolutely must not "simplify" this to
+ join j x = rhs
+ in blah
+because j's return type is (Maybe t), quite different to blah's.
+
+You might think this could never happen, because j can't be
+tail-called in the body if the body returns a constructor. But
+in !3113 we had a /dead/ join point (which is not illegal),
+and its return type was wonky.
+
+The simple thing is not to float a join point. The next iteration
+of the simplifier will sort everything out. And it there is
+a join point, the chances are that the body is not a constructor
+application, so failing faster is good.
+
Note [exprIsConApp_maybe for data-con wrappers: tricky corner]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally speaking
@@ -1062,6 +1087,8 @@ exprIsConApp_maybe (in_scope, id_unf) expr
in go subst' (float:floats) body (CC args co)
go subst floats (Let (NonRec bndr rhs) expr) cont
+ | not (isJoinId bndr)
+ -- Crucial guard! See Note [Don't float join points]
= let rhs' = subst_expr subst rhs
(subst', bndr') = subst_bndr subst bndr
float = FloatLet (NonRec bndr' rhs')
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -760,7 +760,13 @@ data ArgInfo = CpeApp CoreArg
| CpeCast Coercion
| CpeTick (Tickish Id)
-{- Note [runRW arg]
+instance Outputable ArgInfo where
+ ppr (CpeApp arg) = text "app" <+> ppr arg
+ ppr (CpeCast co) = text "cast" <+> ppr co
+ ppr (CpeTick tick) = text "tick" <+> ppr tick
+
+{-
+ Note [runRW arg]
~~~~~~~~~~~~~~~~~~~
If we got, say
runRW# (case bot of {})
@@ -823,14 +829,23 @@ 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)
- cpe_app env (Var f) [CpeApp _runtimeRep at Type{}, CpeApp _type at Type{}, CpeApp arg] 1
+ cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) n
| 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
-- 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 [] 0
- _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
+ Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2)
+ _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1)
+ -- TODO: What about casts?
+
+ cpe_app _env (Var f) args n
+ | f `hasKey` runRWKey
+ = pprPanic "cpe_app(runRW#)" (ppr args $$ ppr n)
+
cpe_app env (Var v) args depth
= do { v1 <- fiddleCCall v
; let e2 = lookupCorePrepEnv env v1
@@ -959,8 +974,77 @@ pragma. It is levity-polymorphic.
=> (State# RealWorld -> (# State# RealWorld, o #))
-> (# State# RealWorld, o #)
-It needs no special treatment in GHC except this special inlining here
-in CorePrep (and in GHC.CoreToByteCode).
+It's correctness needs no special treatment in GHC except this special inlining
+here in CorePrep (and in GHC.CoreToByteCode).
+
+However, there are a variety of optimisation opportunities that the simplifier
+takes advantage of. See Note [Simplification of runRW#].
+
+
+Note [Simplification of runRW#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the program,
+
+ case runRW# (\s -> let n = I# 42# in n) of
+ I# n# -> f n#
+
+There is no reason why we should allocate an I# constructor given that we
+immediately destructure it. To avoid this the simplifier will push strict
+contexts into runRW's continuation. That is, it transforms
+
+ K[ runRW# @r @ty cont ]
+ ~>
+ runRW# @r @ty K[cont]
+
+This has a few interesting implications. Consider, for instance, this program:
+
+ join j = ...
+ in case runRW# @r @ty cont of
+ result -> jump j result
+
+Performing the transform described above would result in:
+
+ join j x = ...
+ in runRW# @r @ty (\s ->
+ case cont of in
+ result -> jump j result
+ )
+
+If runRW# were a "normal" function this call to join point j would not be
+allowed in its continuation argument. However, since runRW# is inlined (as
+described in Note [runRW magic] above), such join point occurences are
+completely fine. Both occurrence analysis and Core Lint have special treatment
+for runRW# applications. See Note [Linting of runRW#] for details on the latter.
+
+Moreover, it's helpful to ensure that runRW's continuation isn't floated out
+(since doing so would then require a call, whereas we would otherwise end up
+with straight-line). Consequently, GHC.Core.Opt.SetLevels.lvlApp has special
+treatment for runRW# applications, ensure the arguments are not floated if
+MFEs.
+
+Other considered designs
+------------------------
+
+One design that was rejected was to *require* that runRW#'s continuation be
+headed by a lambda. However, this proved to be quite fragile. For instance,
+SetLevels is very eager to float bottoming expressions. For instance given
+something of the form,
+
+ runRW# @r @ty (\s -> case expr of x -> undefined)
+
+SetLevels will see that the body the lambda is bottoming and will consequently
+float it to the top-level (assuming expr has no free coercion variables which
+prevent this). We therefore end up with
+
+ runRW# @r @ty (\s -> lvl s)
+
+Which the simplifier will beta reduce, leaving us with
+
+ runRW# @r @ty lvl
+
+Breaking our desired invariant. Ultimately we decided to simply accept that
+the continuation may not be a manifest lambda.
+
-- ---------------------------------------------------------------------------
-- CpeArg: produces a result satisfying CpeArg
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -482,7 +482,6 @@ mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg
Var v1 | isInternalName (idName v1)
-> v1 -- Note [Desugaring seq], points (2) and (3)
_ -> mkWildValBinder ty1
-
mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make
-- NB: No argument can be levity polymorphic
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ede8dd245ba9ee89db052260c307e784e8eab474...8d548e8304ea7d8f3955681597be0c655ab6fb2d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ede8dd245ba9ee89db052260c307e784e8eab474...8d548e8304ea7d8f3955681597be0c655ab6fb2d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200424/dce27d6c/attachment-0001.html>
More information about the ghc-commits
mailing list