[Git][ghc/ghc][master] Do absence analysis on stable unfoldings
Marge Bot
gitlab at gitlab.haskell.org
Thu Sep 17 05:27:33 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7cf09ab0 by Simon Peyton Jones at 2020-09-17T01:27:25-04:00
Do absence analysis on stable unfoldings
Ticket #18638 showed that Very Bad Things happen if we fail
to do absence analysis on stable unfoldings. It's all described
in Note [Absence analysis for stable unfoldings and RULES].
I'm a bit surprised this hasn't bitten us before. Fortunately
the fix is pretty simple.
- - - - -
6 changed files:
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Types/Demand.hs
- + testsuite/tests/simplCore/should_run/T18638.hs
- + testsuite/tests/simplCore/should_run/T18638.stdout
- testsuite/tests/simplCore/should_run/all.T
Changes:
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -34,9 +34,10 @@ module GHC.Core.FVs (
bndrRuleAndUnfoldingVarsDSet,
idFVs,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
- ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
+ ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet, mkRuleInfo,
ruleLhsFreeIds, ruleLhsFreeIdsList,
+ ruleRhsFreeVars, ruleRhsFreeIds,
expr_fvs,
@@ -524,6 +525,14 @@ ruleLhsFVIds (BuiltinRule {}) = emptyFV
ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
= filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
+ruleRhsFreeIds :: CoreRule -> VarSet
+-- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- and returns them as a non-deterministic set
+ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet
+ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
+ = fvVarSet $ filterFV isLocalId $
+ addBndrs bndrs $ exprs_fvs args
+
{-
Note [Rule free var hack] (Not a hack any more)
~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.Core.Multiplicity ( scaledThing )
import GHC.Core.Seq ( seqBinds )
import GHC.Utils.Outputable
import GHC.Types.Var.Env
+import GHC.Types.Var.Set
import GHC.Types.Basic
import Data.List ( mapAccumL )
import GHC.Core.DataCon
@@ -32,6 +33,7 @@ import GHC.Types.Id.Info
import GHC.Core.Utils
import GHC.Core.TyCon
import GHC.Core.Type
+import GHC.Core.FVs ( exprFreeIds, ruleRhsFreeIds )
import GHC.Core.Coercion ( Coercion, coVarsOfCo )
import GHC.Core.FamInstEnv
import GHC.Utils.Misc
@@ -552,7 +554,9 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-- See Note [Demand signatures are computed for a threshold demand based on idArity]
= mkRhsDmd env rhs_arity rhs
- (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs
+ (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs
+ DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
+
sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
-- See Note [Aggregated demand for cardinality]
@@ -560,10 +564,23 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
Nothing -> rhs_fv
+ rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs
+
-- See Note [Lazy and unleashable free variables]
- (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
+ (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv2
is_thunk = not (exprIsHNF rhs) && not (isJoinId id)
+ -- Find the RHS free vars of the unfoldings and RULES
+ -- See Note [Absence analysis for stable unfoldings and RULES]
+ extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $
+ idCoreRules id
+
+ unf = realIdUnfolding id
+ unf_fvs | isStableUnfolding unf
+ , Just unf_body <- maybeUnfoldingTemplate unf
+ = exprFreeIds unf_body
+ | otherwise = emptyVarSet
+
-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for
-- unleashing on the given function's @rhs@, by creating
-- a call demand of @rhs_arity@
@@ -799,6 +816,43 @@ Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown
forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity.
+Note [Absence analysis for stable unfoldings and RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticket #18638 shows that it's really important to do absence analysis
+for stable unfoldings. Consider
+
+ g = blah
+
+ f = \x. ...no use of g....
+ {- f's stable unfolding is f = \x. ...g... -}
+
+If f is ever inlined we use 'g'. But f's current RHS makes no use
+of 'g', so if we don't look at the unfolding we'll mark g as Absent,
+and transform to
+
+ g = error "Entered absent value"
+ f = \x. ...
+ {- f's stable unfolding is f = \x. ...g... -}
+
+Now if f is subsequently inlined, we'll use 'g' and ... disaster.
+
+SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands
+on its free variables) so that no variable mentioned in its unfolding
+is Absent. This is done by the function Demand.keepAliveDmdEnv.
+
+ALSO: do the same for Ids free in the RHS of any RULES for f.
+
+PS: You may wonder how it can be that f's optimised RHS has somehow
+discarded 'g', but when f is inlined we /don't/ discard g in the same
+way. I think a simple example is
+ g = (a,b)
+ f = \x. fst g
+ {-# INLINE f #-}
+
+Now f's optimised RHS will be \x.a, but if we change g to (error "..")
+(since it is apparently Absent) and then inline (\x. fst g) we get
+disaster. But regardless, #18638 was a more complicated version of
+this, that actually happened in practice.
Historical Note [Product demands for function body]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Types.Demand (
BothDmdArg, mkBothDmdArg, toBothDmdArg,
nopDmdType, botDmdType, addDemand,
- DmdEnv, emptyDmdEnv,
+ DmdEnv, emptyDmdEnv, keepAliveDmdEnv,
peelFV, findIdDemand,
Divergence(..), lubDivergence, isDeadEndDiv,
@@ -59,8 +59,9 @@ module GHC.Types.Demand (
import GHC.Prelude
-import GHC.Types.Var ( Var )
+import GHC.Types.Var ( Var, Id )
import GHC.Types.Var.Env
+import GHC.Types.Var.Set
import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Data.Maybe ( orElse )
@@ -809,10 +810,22 @@ splitFVs is_thunk rhs_fvs
:*:
addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs })
-data StrictPair a b = !a :*: !b
+keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv
+-- (keepAliveDmdType dt vs) makes sure that the Ids in vs have
+-- /some/ usage in the returned demand types -- they are not Absent
+-- See Note [Absence analysis for stable unfoldings and RULES]
+-- in GHC.Core.Opt.DmdAnal
+keepAliveDmdEnv env vs
+ = nonDetStrictFoldVarSet add env vs
+ where
+ add :: Id -> DmdEnv -> DmdEnv
+ add v env = extendVarEnv_C add_dmd env v topDmd
-strictPairToTuple :: StrictPair a b -> (a, b)
-strictPairToTuple (x :*: y) = (x, y)
+ add_dmd :: Demand -> Demand -> Demand
+ -- If the existing usage is Absent, make it used
+ -- Otherwise leave it alone
+ add_dmd dmd _ | isAbsDmd dmd = topDmd
+ | otherwise = dmd
splitProdDmd_maybe :: Demand -> Maybe [Demand]
-- Split a product into its components, iff there is any
@@ -827,6 +840,11 @@ splitProdDmd_maybe (JD { sd = s, ud = u })
(Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
_ -> Nothing
+data StrictPair a b = !a :*: !b
+
+strictPairToTuple :: StrictPair a b -> (a, b)
+strictPairToTuple (x :*: y) = (x, y)
+
{- *********************************************************************
* *
TypeShape and demand trimming
@@ -1541,9 +1559,9 @@ There are several wrinkles:
can be evaluated in a short finite time -- and that rules out nasty
cases like the one above. (I'm not quite sure why this was a
problem in an earlier version of GHC, but it isn't now.)
+-}
-
-************************************************************************
+{- *********************************************************************
* *
Demand signatures
* *
=====================================
testsuite/tests/simplCore/should_run/T18638.hs
=====================================
@@ -0,0 +1,54 @@
+{-# LANGUAGE ExistentialQuantification, BangPatterns #-}
+{-# OPTIONS_GHC -O #-}
+
+module Main (main) where
+
+import Data.IORef (newIORef, readIORef)
+
+data Step s = Done
+ | Skip !s
+ | Yield !Char !s
+
+data Stream = forall s. Stream (s -> Step s) !s !Int
+
+unstreamList :: Stream -> [Char]
+unstreamList (Stream next s0 _) = unfold s0
+ where unfold !s = case next s of
+ Done -> []
+ Skip s' -> unfold s'
+ Yield x s' -> x : unfold s'
+{-# INLINE [0] unstreamList #-}
+
+appendS :: Stream -> Stream -> Stream
+appendS (Stream next s len) _ = Stream next s len
+{-# INLINE [0] appendS #-}
+
+justifyLeftI :: Int -> Int -> Stream
+justifyLeftI k u =
+ let
+ next Nothing = next (Just 0)
+ next (Just n)
+ | n < k = Yield 'a' (Just (n+1))
+ | otherwise = Done
+ {-# INLINE next #-}
+
+ in Stream next Nothing (max k u)
+{-# INLINE [0] justifyLeftI #-}
+
+prettyPrintLogStats :: Int -> [String]
+prettyPrintLogStats rawResults = map fromRow columns
+ where
+ columns :: [Int]
+ columns = map (\_ -> 0) [rawResults]
+
+ moduleLen, lineLen :: Int
+ (moduleLen, lineLen) = foldr (\_ (_,_) -> (5, 2)) (0, 0) columns
+
+ fromRow :: Int -> String
+ fromRow x = unstreamList (justifyLeftI moduleLen x `appendS` justifyLeftI lineLen x)
+
+main :: IO ()
+main = do
+ timingsRef <- newIORef 0
+ timings <- readIORef timingsRef
+ putStrLn $ concat $ prettyPrintLogStats timings
=====================================
testsuite/tests/simplCore/should_run/T18638.stdout
=====================================
@@ -0,0 +1 @@
+aaaaa
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -92,3 +92,4 @@ test('T17206', exit_code(1), compile_and_run, [''])
test('T17151', [], multimod_compile_and_run, ['T17151', ''])
test('T18012', normal, compile_and_run, [''])
test('T17744', normal, compile_and_run, [''])
+test('T18638', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cf09ab013778227caa07b5d7ec9acd5dedd1817
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cf09ab013778227caa07b5d7ec9acd5dedd1817
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/20200917/a4c37e99/attachment-0001.html>
More information about the ghc-commits
mailing list