[Git][ghc/ghc][wip/T18043] 7 commits: testsuite: Add testcase for #18733
Ben Gamari
gitlab at gitlab.haskell.org
Sat Nov 14 12:07:40 UTC 2020
Ben Gamari pushed to branch wip/T18043 at Glasgow Haskell Compiler / GHC
Commits:
787e93ae by Ben Gamari at 2020-11-11T23:14:11-05:00
testsuite: Add testcase for #18733
- - - - -
5353fd50 by Ben Gamari at 2020-11-12T10:05:30-05:00
compiler: Fix recompilation checking
In ticket #18733 we noticed a rather serious deficiency in the current
fingerprinting logic for recursive groups. I have described the old
fingerprinting story and its problems in Note [Fingerprinting recursive
groups] and have reworked the story accordingly to avoid these issues.
Fixes #18733.
- - - - -
63fa3997 by Sebastian Graf at 2020-11-13T14:29:39-05:00
Arity: Rework `ArityType` to fix monotonicity (#18870)
As we found out in #18870, `andArityType` is not monotone, with
potentially severe consequences for termination of fixed-point
iteration. That showed in an abundance of "Exciting arity" DEBUG
messages that are emitted whenever we do more than one step in
fixed-point iteration.
The solution necessitates also recording `OneShotInfo` info for
`ABot` arity type. Thus we get the following definition for `ArityType`:
```
data ArityType = AT [OneShotInfo] Divergence
```
The majority of changes in this patch are the result of refactoring use
sites of `ArityType` to match the new definition.
The regression test `T18870` asserts that we indeed don't emit any DEBUG
output anymore for a function where we previously would have.
Similarly, there's a regression test `T18937` for #18937, which we
expect to be broken for now.
Fixes #18870.
- - - - -
197d59fa by Sebastian Graf at 2020-11-13T14:29:39-05:00
Arity: Emit "Exciting arity" warning only after second iteration (#18937)
See Note [Exciting arity] why we emit the warning at all and why we only
do after the second iteration now.
Fixes #18937.
- - - - -
de7ec9dd by David Eichmann at 2020-11-13T14:30:16-05:00
Add rts_listThreads and rts_listMiscRoots to RtsAPI.h
These are used to find the current roots of the garbage collector.
Co-authored-by: Sven Tennie's avatarSven Tennie <sven.tennie at gmail.com>
Co-authored-by: Matthew Pickering's avatarMatthew Pickering <matthewtpickering at gmail.com>
Co-authored-by: default avatarBen Gamari <bgamari.foss at gmail.com>
- - - - -
24a86f09 by Ben Gamari at 2020-11-13T14:30:51-05:00
gitlab-ci: Cache cabal store in linting job
- - - - -
aaaa833b by Ben Gamari at 2020-11-14T07:07:21-05:00
rts: Flush eventlog buffers from flushEventLog
As noted in #18043, flushTrace failed flush anything beyond the writer.
This means that a significant amount of data sitting in capability-local
event buffers may never get flushed, despite the users' pleads for us to
flush.
Fix this by making flushEventLog flush all of the event buffers before
flushing the writer.
Fixes #18043.
- - - - -
30 changed files:
- .gitlab-ci.yml
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Iface/Recomp.hs
- includes/RtsAPI.h
- includes/rts/EventLogWriter.h
- libraries/base/Debug/Trace.hs
- rts/Capability.c
- rts/Capability.h
- rts/RtsAPI.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- + testsuite/tests/arityanal/should_compile/T18870.hs
- + testsuite/tests/arityanal/should_compile/T18937.hs
- testsuite/tests/arityanal/should_compile/all.T
- + testsuite/tests/driver/T18733/Library1.hs
- + testsuite/tests/driver/T18733/Library2.hs
- + testsuite/tests/driver/T18733/Main.hs
- + testsuite/tests/driver/T18733/Makefile
- + testsuite/tests/driver/T18733/T18733.stdout
- + testsuite/tests/driver/T18733/all.T
- testsuite/tests/rts/pause-resume/all.T
- + testsuite/tests/rts/pause-resume/list_threads_and_misc_roots.hs
- + testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.c
- + testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.h
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -307,16 +307,20 @@ hadrian-ghc-in-ghci:
- .gitlab/ci.sh setup
- cabal update
- cd hadrian; cabal new-build -j`../mk/detect-cpu-count.sh` --with-compiler=$GHC --project-file=ci.project; cd ..
+ after_script:
+ - cp -Rf $HOME/.cabal cabal-cache
variables:
GHC_FLAGS: -Werror
+ cache:
+ key: lint
+ paths:
+ - cabal-cache
lint-base:
extends: .lint-params
script:
- hadrian/build -c -j stage1:lib:base
- hadrian/build -j lint:base
- cache:
- key: lint
############################################################
# Validation via Pipelines (make)
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -17,14 +17,14 @@ module GHC.Core.Opt.Arity
, etaExpand, etaExpandAT
, exprBotStrictness_maybe
- -- ** ArityType
- , ArityType(..), expandableArityType, arityTypeArity
- , maxWithArity, isBotArityType, idArityType
+ -- ** ArityType
+ , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType
+ , arityTypeArity, maxWithArity, idArityType
- -- ** Join points
+ -- ** Join points
, etaExpandToJoinPoint, etaExpandToJoinPointRule
- -- ** Coercions and casts
+ -- ** Coercions and casts
, pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg
, pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo
)
@@ -455,27 +455,36 @@ ArityType is the result of a compositional analysis on expressions,
from which we can decide the real arity of the expression (extracted
with function exprEtaExpandArity).
+We use the following notation:
+ at ::= \o1..on.div
+ div ::= T | x | ⊥
+ o ::= ? | 1
+And omit the \. if n = 0. Examples:
+ \?11.T stands for @AT [NoOneShotInfo,OneShotLam,OneShotLam] topDiv@
+ ⊥ stands for @AT [] botDiv@
+See the 'Outputable' instance for more information. It's pretty simple.
+
Here is what the fields mean. If an arbitrary expression 'f' has
ArityType 'at', then
- * If at = ABot n, then (f x1..xn) definitely diverges. Partial
- applications to fewer than n args may *or may not* diverge.
+ * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@
+ definitely diverges. Partial applications to fewer than n args may *or
+ may not* diverge.
We allow ourselves to eta-expand bottoming functions, even
if doing so may lose some `seq` sharing,
let x = <expensive> in \y. error (g x y)
==> \y. let x = <expensive> in error (g x y)
- * If at = ATop as, and n=length as,
- then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing,
- assuming the calls of f respect the one-shot-ness of
- its definition.
+ * If @at = AT [o1,..,on] topDiv@ (notation: \o1..on.T), then expanding 'f'
+ to @\x1..xn. f x1..xn@ loses no sharing, assuming the calls of f respect
+ the one-shot-ness o1..on of its definition.
- NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f'
- can have ArityType as ATop, with length as > 0, only if e1 e2 are
- themselves.
+ NB 'f' is an arbitrary expression, eg @f = g e1 e2 at . This 'f' can have
+ arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves
+ cheap.
- * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely
+ * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely
really functions, or bottom, but *not* casts from a data type, in
at least one case branch. (If it's a function in one case branch but
an unsafe cast from a data type in another, the program is bogus.)
@@ -485,62 +494,128 @@ ArityType 'at', then
Example:
f = \x\y. let v = <expensive> in
\s(one-shot) \t(one-shot). blah
- 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot]
+ 'f' has arity type \??11.T
The one-shot-ness means we can, in effect, push that
'let' inside the \st.
Suppose f = \xy. x+y
-Then f :: AT [False,False] ATop
- f v :: AT [False] ATop
- f <expensive> :: AT [] ATop
-
--------------------- Main arity code ----------------------------
+Then f :: \??.T
+ f v :: \?.T
+ f <expensive> :: T
-}
-data ArityType -- See Note [ArityType]
- = ATop [OneShotInfo]
- | ABot Arity
- deriving( Eq )
- -- There is always an explicit lambda
- -- to justify the [OneShot], or the Arity
-
+-- | The analysis lattice of arity analysis. It is isomorphic to
+--
+-- @
+-- data ArityType'
+-- = AEnd Divergence
+-- | ALam OneShotInfo ArityType'
+-- @
+--
+-- Which is easier to display the Hasse diagram for:
+--
+-- @
+-- ALam OneShotLam at
+-- |
+-- AEnd topDiv
+-- |
+-- ALam NoOneShotInfo at
+-- |
+-- AEnd exnDiv
+-- |
+-- AEnd botDiv
+-- @
+--
+-- where the @at@ fields of @ALam@ are inductively subject to the same order.
+-- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2 at .
+--
+-- Why the strange Top element? See Note [Combining case branches].
+--
+-- We rely on this lattice structure for fixed-point iteration in
+-- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].
+data ArityType
+ = AT ![OneShotInfo] !Divergence
+ -- ^ @AT oss div@ means this value can safely be eta-expanded @length oss@
+ -- times, provided use sites respect the 'OneShotInfo's in @oss at .
+ -- A 'OneShotLam' annotation can come from two sources:
+ -- * The user annotated a lambda as one-shot with 'GHC.Exts.oneShot'
+ -- * It's from a lambda binder of a type affected by `-fstate-hack`.
+ -- See 'idStateHackOneShotInfo'.
+ -- In both cases, 'OneShotLam' should win over 'NoOneShotInfo', see
+ -- Note [Combining case branches].
+ --
+ -- If @div@ is dead-ending ('isDeadEndDiv'), then application to
+ -- @length os@ arguments will surely diverge, similar to the situation
+ -- with 'DmdType'.
+ deriving Eq
+
+-- | This is the BNF of the generated output:
+--
+-- @
+-- @
+--
+-- We format
+-- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and
+-- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively.
+-- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T at .
+-- If the one-shot info is empty, we omit the leading @\. at .
instance Outputable ArityType where
- ppr (ATop os) = text "ATop" <> parens (ppr (length os))
- ppr (ABot n) = text "ABot" <> parens (ppr n)
+ ppr (AT oss div)
+ | null oss = pp_div div
+ | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div
+ where
+ pp_div Diverges = char '⊥'
+ pp_div ExnOrDiv = char 'x'
+ pp_div Dunno = char 'T'
+ pp_os OneShotLam = char '1'
+ pp_os NoOneShotInfo = char '?'
-arityTypeArity :: ArityType -> Arity
--- The number of value args for the arity type
-arityTypeArity (ATop oss) = length oss
-arityTypeArity (ABot ar) = ar
+mkBotArityType :: [OneShotInfo] -> ArityType
+mkBotArityType oss = AT oss botDiv
-expandableArityType :: ArityType -> Bool
--- True <=> eta-expansion will add at least one lambda
-expandableArityType (ATop oss) = not (null oss)
-expandableArityType (ABot ar) = ar /= 0
+botArityType :: ArityType
+botArityType = mkBotArityType []
-isBotArityType :: ArityType -> Bool
-isBotArityType (ABot {}) = True
-isBotArityType (ATop {}) = False
+mkTopArityType :: [OneShotInfo] -> ArityType
+mkTopArityType oss = AT oss topDiv
-arityTypeOneShots :: ArityType -> [OneShotInfo]
-arityTypeOneShots (ATop oss) = oss
-arityTypeOneShots (ABot ar) = replicate ar OneShotLam
- -- If we are diveging or throwing an exception anyway
- -- it's fine to push redexes inside the lambdas
+topArityType :: ArityType
+topArityType = mkTopArityType []
-botArityType :: ArityType
-botArityType = ABot 0 -- Unit for andArityType
+-- | The number of value args for the arity type
+arityTypeArity :: ArityType -> Arity
+arityTypeArity (AT oss _) = length oss
-maxWithArity :: ArityType -> Arity -> ArityType
-maxWithArity at@(ABot {}) _ = at
-maxWithArity at@(ATop oss) ar
- | oss `lengthAtLeast` ar = at
- | otherwise = ATop (take ar (oss ++ repeat NoOneShotInfo))
+-- | True <=> eta-expansion will add at least one lambda
+expandableArityType :: ArityType -> Bool
+expandableArityType at = arityTypeArity at /= 0
+
+-- | See Note [Dead ends] in "GHC.Types.Demand".
+-- Bottom implies a dead end.
+isDeadEndArityType :: ArityType -> Bool
+isDeadEndArityType (AT _ div) = isDeadEndDiv div
-vanillaArityType :: ArityType
-vanillaArityType = ATop [] -- Totally uninformative
+-- | Expand a non-bottoming arity type so that it has at least the given arity.
+maxWithArity :: ArityType -> Arity -> ArityType
+maxWithArity at@(AT oss div) !ar
+ | isDeadEndArityType at = at
+ | oss `lengthAtLeast` ar = at
+ | otherwise = AT (take ar $ oss ++ repeat NoOneShotInfo) div
+
+-- | Trim an arity type so that it has at most the given arity.
+-- Any excess 'OneShotInfo's are truncated to 'topDiv', even if they end in
+-- 'ABot'.
+minWithArity :: ArityType -> Arity -> ArityType
+minWithArity at@(AT oss _) ar
+ | oss `lengthAtMost` ar = at
+ | otherwise = AT (take ar oss) topDiv
+
+takeWhileOneShot :: ArityType -> ArityType
+takeWhileOneShot (AT oss div)
+ | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv
+ | otherwise = AT (takeWhile isOneShotInfo oss) div
-- | The Arity returned is the number of value args the
-- expression can be applied to without doing much work
@@ -551,8 +626,9 @@ exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e
getBotArity :: ArityType -> Maybe Arity
-- Arity of a divergent function
-getBotArity (ABot n) = Just n
-getBotArity _ = Nothing
+getBotArity (AT oss div)
+ | isDeadEndDiv div = Just $ length oss
+ | otherwise = Nothing
----------------------
findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
@@ -563,26 +639,26 @@ findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
-- so it is safe to expand e ==> (\x1..xn. e x1 .. xn)
-- (b) if is_bot=True, then e applied to n args is guaranteed bottom
findRhsArity dflags bndr rhs old_arity
- = go (step botArityType)
+ = go 0 botArityType
-- We always do one step, but usually that produces a result equal to
- -- old_arity, and then we stop right away (since arities should not
- -- decrease)
+ -- old_arity, and then we stop right away, because old_arity is assumed
+ -- to be sound. In other words, arities should never decrease.
-- Result: the common case is that there is just one iteration
where
- go :: ArityType -> ArityType
- go cur_atype@(ATop oss)
- | length oss <= old_arity = cur_atype
- go cur_atype
- | new_atype == cur_atype = cur_atype
- | otherwise =
-#if defined(DEBUG)
- pprTrace "Exciting arity"
- (vcat [ ppr bndr <+> ppr cur_atype <+> ppr new_atype
- , ppr rhs])
-#endif
- go new_atype
+ go :: Int -> ArityType -> ArityType
+ go !n cur_at@(AT oss div)
+ | not (isDeadEndDiv div) -- the "stop right away" case
+ , length oss <= old_arity = cur_at -- from above
+ | next_at == cur_at = cur_at
+ | otherwise =
+ -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]
+ WARN( debugIsOn && n > 2, text "Exciting arity"
+ $$ nest 2 (
+ ppr bndr <+> ppr cur_at <+> ppr next_at
+ $$ ppr rhs) )
+ go (n+1) next_at
where
- new_atype = step cur_atype
+ next_at = step cur_at
step :: ArityType -> ArityType
step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $
@@ -607,7 +683,7 @@ fifteen years ago! It also shows up in the code for 'rnf' on lists
in #4138.
We do the neccessary, quite simple fixed-point iteration in 'findRhsArity',
-which assumes for a single binding @botArityType@ on the first run and iterates
+which assumes for a single binding 'ABot' on the first run and iterates
until it finds a stable arity type. Two wrinkles
* We often have to ask (see the Case or Let case of 'arityType') whether some
@@ -630,6 +706,30 @@ until it finds a stable arity type. Two wrinkles
by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case
of 'arityType'.
+Note [Exciting Arity]
+~~~~~~~~~~~~~~~~~~~~~
+The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost
+all cases. To get notified of cases where we need an usual number of iterations,
+we emit a warning in debug mode, so that we can investigate and make sure that
+we really can't do better. It's a gross hack, but catches real bugs (#18870).
+
+Now, which number is "unusual"? We pick n > 2. Here's a pretty common and
+expected example that takes two iterations and would ruin the specificity
+of the warning (from T18937):
+
+ f :: [Int] -> Int -> Int
+ f [] = id
+ f (x:xs) = let y = sum [0..x]
+ in \z -> f xs (y + z)
+
+Fixed-point iteration starts with arity type ⊥ for f. After the first
+iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally
+'floatIn' the let-binding (see its bottom case). After the second iteration,
+we get arity type \?.T, e.g. arity 1, because now we are no longer allowed
+to floatIn the non-cheap let-binding. Which is all perfectly benign, but
+means we do two iterations (well, actually 3 'step's to detect we are stable)
+and don't want to emit the warning.
+
Note [Eta expanding through dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the experimental -fdicts-cheap flag is on, we eta-expand through
@@ -651,44 +751,45 @@ dictionary-typed expression, but that's more work.
-}
arityLam :: Id -> ArityType -> ArityType
-arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as)
-arityLam _ (ABot n) = ABot (n+1)
+arityLam id (AT oss div) = AT (idStateHackOneShotInfo id : oss) div
floatIn :: Bool -> ArityType -> ArityType
-- We have something like (let x = E in b),
-- where b has the given arity type.
-floatIn _ (ABot n) = ABot n
-floatIn True (ATop as) = ATop as
-floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as)
- -- If E is not cheap, keep arity only for one-shots
+floatIn cheap at
+ | isDeadEndArityType at || cheap = at
+ -- If E is not cheap, keep arity only for one-shots
+ | otherwise = takeWhileOneShot at
arityApp :: ArityType -> Bool -> ArityType
-- Processing (fun arg) where at is the ArityType of fun,
-- Knock off an argument and behave like 'let'
-arityApp (ABot 0) _ = ABot 0
-arityApp (ABot n) _ = ABot (n-1)
-arityApp (ATop []) _ = ATop []
-arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)
-
-andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case'
--- This is least upper bound in the ArityType lattice
-andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max]
-andArityType (ATop as) (ABot _) = ATop as
-andArityType (ABot _) (ATop bs) = ATop bs
-andArityType (ATop as) (ATop bs) = ATop (as `combine` bs)
- where -- See Note [Combining case branches]
- combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs
- combine [] bs = takeWhile isOneShotInfo bs
- combine as [] = takeWhile isOneShotInfo as
-
-{- Note [ABot branches: use max]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div)
+arityApp at _ = at
+
+-- | Least upper bound in the 'ArityType' lattice.
+-- See the haddocks on 'ArityType' for the lattice.
+--
+-- Used for branches of a @case at .
+andArityType :: ArityType -> ArityType -> ArityType
+andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2)
+ | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2)
+ = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches]
+andArityType (AT [] div1) at2
+ | isDeadEndDiv div1 = at2 -- Note [ABot branches: max arity wins]
+ | otherwise = takeWhileOneShot at2 -- See Note [Combining case branches]
+andArityType at1 (AT [] div2)
+ | isDeadEndDiv div2 = at1 -- Note [ABot branches: max arity wins]
+ | otherwise = takeWhileOneShot at1 -- See Note [Combining case branches]
+
+{- Note [ABot branches: max arity wins]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider case x of
True -> \x. error "urk"
False -> \xy. error "urk2"
-Remember: ABot n means "if you apply to n args, it'll definitely diverge".
-So we need (ABot 2) for the whole thing, the /max/ of the ABot arities.
+Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge".
+So we need \??.⊥ for the whole thing, the /max/ of both arities.
Note [Combining case branches]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -698,15 +799,18 @@ Consider
True -> z
False -> \s(one-shot). e1
in go2 x
-We *really* want to eta-expand go and go2.
+We *really* want to respect the one-shot annotation provided by the
+user and eta-expand go and go2.
When combining the branches of the case we have
- ATop [] `andAT` ATop [OneShotLam]
-and we want to get ATop [OneShotLam]. But if the inner
-lambda wasn't one-shot we don't want to do this.
-(We need a proper arity analysis to justify that.)
+ T `andAT` \1.T
+and we want to get \1.T.
+But if the inner lambda wasn't one-shot (\?.T) we don't want to do this.
+(We need a usage analysis to justify that.)
So we combine the best of the two branches, on the (slightly dodgy)
basis that if we know one branch is one-shot, then they all must be.
+Surprisingly, this means that the one-shot arity type is effectively the top
+element of the lattice.
Note [Arity trimming]
~~~~~~~~~~~~~~~~~~~~~
@@ -718,16 +822,17 @@ most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of
calling arityType on (\x y. blah). Failing to do so, and hence breaking the
exprArity invariant, led to #5441.
-How to trim? For ATop, it's easy. But we must take great care with ABot.
-Suppose the expression was (\x y. error "urk"), we'll get (ABot 2). We
-absolutely must not trim that to (ABot 1), because that claims that
-((\x y. error "urk") |> co) diverges when given one argument, which it
-absolutely does not. And Bad Things happen if we think something returns bottom
-when it doesn't (#16066).
+How to trim? If we end in topDiv, it's easy. But we must take great care with
+dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"),
+we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that
+claims that ((\x y. error "urk") |> co) diverges when given one argument,
+which it absolutely does not. And Bad Things happen if we think something
+returns bottom when it doesn't (#16066).
-So, do not reduce the 'n' in (ABot n); rather, switch (conservatively) to ATop.
+So, if we need to trim a dead-ending arity type, switch (conservatively) to
+topDiv.
-Historical note: long ago, we unconditionally switched to ATop when we
+Historical note: long ago, we unconditionally switched to topDiv when we
encountered a cast, but that is far too conservative: see #5475
-}
@@ -838,25 +943,22 @@ myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of
Nothing -> isCheapApp fn n_val_args
-- @Just at@ means local function with @at@ as current ArityType.
-- Roughly approximate what 'isCheapApp' is doing.
- Just (ABot _) -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils
- Just (ATop oss) -> n_val_args < length oss -- Essentially isWorkFreeApp
+ Just (AT oss div)
+ | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils
+ | n_val_args < length oss -> True -- Essentially isWorkFreeApp
+ | otherwise -> False
----------------
arityType :: ArityEnv -> CoreExpr -> ArityType
arityType env (Cast e co)
- = case arityType env e of
- ATop os -> ATop (take co_arity os) -- See Note [Arity trimming]
- ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo)
- | otherwise -> ABot n
+ = minWithArity (arityType env e) co_arity -- See Note [Arity trimming]
where
co_arity = length (typeArity (coercionRKind co))
-- See Note [exprArity invariant] (2); must be true of
-- arityType too, since that is how we compute the arity
-- of variables, and they in turn affect result of exprArity
-- #5441 is a nice demo
- -- However, do make sure that ATop -> ATop and ABot -> ABot!
- -- Casts don't affect that part. Getting this wrong provoked #5475
arityType env (Var v)
| v `elemVarSet` ae_joins env
@@ -887,18 +989,15 @@ arityType env (App fun arg )
--
arityType env (Case scrut bndr _ alts)
| exprIsDeadEnd scrut || null alts
- = botArityType -- Do not eta expand
- -- See Note [Dealing with bottom (1)]
+ = botArityType -- Do not eta expand. See Note [Dealing with bottom (1)]
| not (pedanticBottoms env) -- See Note [Dealing with bottom (2)]
, myExprIsCheap env scrut (Just (idType bndr))
= alts_type
| exprOkForSpeculation scrut
= alts_type
- | otherwise -- In the remaining cases we may not push
- = case alts_type of -- evaluation of the scrutinee in
- ATop as -> ATop (takeWhile isOneShotInfo as)
- ABot _ -> ATop []
+ | otherwise -- In the remaining cases we may not push
+ = takeWhileOneShot alts_type -- evaluation of the scrutinee in
where
alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]
@@ -938,7 +1037,7 @@ arityType env (Let (Rec prs) e)
arityType env (Tick t e)
| not (tickishIsCode t) = arityType env e
-arityType _ _ = vanillaArityType
+arityType _ _ = topArityType
{- Note [Eta-expansion and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -973,12 +1072,12 @@ So we do this:
body of the let.
* Dually, when we come to a /call/ of a join point, just no-op
- by returning botArityType, the bottom element of ArityType,
+ by returning ABot, the bottom element of ArityType,
which so that: bot `andArityType` x = x
* This works if the join point is bound in the expression we are
taking the arityType of. But if it's bound further out, it makes
- no sense to say that (say) the arityType of (j False) is ABot 0.
+ no sense to say that (say) the arityType of (j False) is ABot.
Bad things happen. So we keep track of the in-scope join-point Ids
in ae_join.
@@ -997,12 +1096,12 @@ idArityType :: Id -> ArityType
idArityType v
| strict_sig <- idStrictness v
, not $ isTopSig strict_sig
- , (ds, res) <- splitStrictSig strict_sig
+ , (ds, div) <- splitStrictSig strict_sig
, let arity = length ds
- = if isDeadEndDiv res then ABot arity
- else ATop (take arity one_shots)
+ -- Every strictness signature admits an arity signature!
+ = AT (take arity one_shots) div
| otherwise
- = ATop (take (idArity v) one_shots)
+ = AT (take (idArity v) one_shots) topDiv
where
one_shots :: [OneShotInfo] -- One-shot-ness derived from the type
one_shots = typeArity (idType v)
@@ -1111,13 +1210,13 @@ Consider
foo = \x. case x of
True -> (\s{os}. blah) |> co
False -> wubble
-We'll get an ArityType for foo of (ATop [NoOneShot,OneShot]).
+We'll get an ArityType for foo of \?1.T.
Then we want to eta-expand to
foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co
That 'eta' binder is fresh, and we really want it to have the
-one-shot flag from the inner \s{osf}. By expanding with the
+one-shot flag from the inner \s{os}. By expanding with the
ArityType gotten from analysing the RHS, we achieve this neatly.
This makes a big difference to the one-shot monad trick;
@@ -1137,8 +1236,8 @@ see Note [The one-shot state monad trick] in GHC.Utils.Monad.
etaExpand :: Arity -> CoreExpr -> CoreExpr
etaExpandAT :: ArityType -> CoreExpr -> CoreExpr
-etaExpand n orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr
-etaExpandAT at orig_expr = eta_expand (arityTypeOneShots at) orig_expr
+etaExpand n orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr
+etaExpandAT (AT oss _) orig_expr = eta_expand oss orig_expr
-- See Note [Eta expansion with ArityType]
-- etaExpand arity e = res
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -42,14 +42,14 @@ import GHC.Core
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
import GHC.Builtin.Names( runRWKey )
import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd
- , mkClosedStrictSig, topDmd, seqDmd, botDiv )
+ , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv )
import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Types.Unique ( hasKey )
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Utils
-import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType
+import GHC.Core.Opt.Arity ( ArityType(..)
, pushCoTyArg, pushCoValArg
, idArityType, etaExpandAT )
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
@@ -796,8 +796,8 @@ addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
addLetBndrInfo new_bndr new_arity_type new_unf
= new_bndr `setIdInfo` info5
where
- new_arity = arityTypeArity new_arity_type
- is_bot = isBotArityType new_arity_type
+ AT oss div = new_arity_type
+ new_arity = length oss
info1 = idInfo new_bndr `setArityInfo` new_arity
@@ -816,11 +816,11 @@ addLetBndrInfo new_bndr new_arity_type new_unf
= info2
-- Bottoming bindings: see Note [Bottoming bindings]
- info4 | is_bot = info3 `setStrictnessInfo` bot_sig
- `setCprInfo` bot_cpr
- | otherwise = info3
+ info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig
+ `setCprInfo` bot_cpr
+ | otherwise = info3
- bot_sig = mkClosedStrictSig (replicate new_arity topDmd) botDiv
+ bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div
bot_cpr = mkCprSig new_arity botCpr
-- Zap call arity info. We have used it by now (via
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1662,8 +1662,8 @@ tryEtaExpandRhs mode bndr rhs
| Just join_arity <- isJoinId_maybe bndr
= do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
oss = [idOneShotInfo id | id <- join_bndrs, isId id]
- arity_type | exprIsDeadEnd join_body = ABot (length oss)
- | otherwise = ATop oss
+ arity_type | exprIsDeadEnd join_body = mkBotArityType oss
+ | otherwise = mkTopArityType oss
; return (arity_type, rhs) }
-- Note [Do not eta-expand join points]
-- But do return the correct arity and bottom-ness, because
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -65,6 +65,7 @@ import Data.Function
import Data.List (find, sortBy, sort)
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Data.Word (Word64)
--Qualified import so we can define a Semigroup instance
-- but it doesn't clash with Outputable.<>
@@ -729,6 +730,77 @@ Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
field of a IfaceClsInst): only in the non-binding case should we include the
fingerprint; in the binding case we shouldn't since it is merely the name of the
thing that we are currently fingerprinting.
+
+
+Note [Fingerprinting recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The fingerprinting of a single recursive group is a rather subtle affair, as
+seen in #18733.
+
+How not to fingerprint
+----------------------
+
+Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a
+group in hash environment `hash_env0`:
+
+ 1. extend hash_env0, giving each declaration in the group the fingerprint 0
+ 2. use this environment to hash the declarations' ABIs, resulting in
+ group_fingerprint
+ 3. produce the final hash environment by extending hash_env0, mapping each
+ declaration of the group to group_fingerprint
+
+However, this is wrong. Consider, for instance, a program like:
+
+ data A = ARecu B | ABase String deriving (Show)
+ data B = BRecu A | BBase Int deriving (Show)
+
+ info :: B
+ info = BBase 1
+
+A consequence of (3) is that A and B will have the same fingerprint. This means
+that if the user changes `info` to:
+
+ info :: A
+ info = ABase "hello"
+
+The program's ABI fingerprint will not change despite `info`'s type, and
+therefore ABI, being clearly different.
+
+However, the incorrectness doesn't end there: (1) means that all recursive
+occurrences of names within the group will be given the same fingerprint. This
+means that the group's fingerprint won't change if we change an occurrence of A
+to B.
+
+Surprisingly, this bug (#18733) lurked for many years before being uncovered.
+
+How we now fingerprint
+----------------------
+
+As seen above, the fingerprinting function must ensure that a groups
+fingerprint captures the structure of within-group occurrences. The scheme that
+we use is:
+
+ 0. To ensure determinism, sort the declarations into a stable order by
+ declaration name
+
+ 1. Extend hash_env0, giving each declaration in the group a sequential
+ fingerprint (e.g. 0, 1, 2, ...).
+
+ 2. Use this environment to hash the declarations' ABIs, resulting in
+ group_fingerprint.
+
+ Since we included the sequence number in step (1) programs identical up to
+ transposition of recursive occurrences are distinguisable, avoiding the
+ second issue mentioned above.
+
+ 3. Produce the final environment by extending hash_env, mapping each
+ declaration of the group to the hash of (group_fingerprint, i), where
+ i is the position of the declaration in the stable ordering.
+
+ Including i in the hash ensures that the first issue noted above is
+ avoided.
+
-}
-- | Add fingerprints for top-level declarations to a 'ModIface'.
@@ -854,18 +926,27 @@ addFingerprints hsc_env iface0
return (env', (hash,decl) : decls_w_hashes)
fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
- = do let decls = map abiDecl abis
+ = do let stable_abis = sortBy cmp_abiNames abis
+ stable_decls = map abiDecl stable_abis
local_env1 <- foldM extend_hash_env local_env
- (zip (repeat fingerprint0) decls)
+ (zip (map mkRecFingerprint [0..]) stable_decls)
+ -- See Note [Fingerprinting recursive groups]
let hash_fn = mk_put_name local_env1
-- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
- let stable_abis = sortBy cmp_abiNames abis
-- put the cycle in a canonical order
hash <- computeFingerprint hash_fn stable_abis
- let pairs = zip (repeat hash) decls
+ let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls
+ -- See Note [Fingerprinting recursive groups]
local_env2 <- foldM extend_hash_env local_env pairs
return (local_env2, pairs ++ decls_w_hashes)
+ -- Make a fingerprint from the ordinal position of a binding in its group.
+ mkRecFingerprint :: Word64 -> Fingerprint
+ mkRecFingerprint i = Fingerprint 0 i
+
+ bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint
+ bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ]
+
-- we have fingerprinted the whole declaration, but we now need
-- to assign fingerprints to all the OccNames that it binds, to
-- use when referencing those OccNames in later declarations.
@@ -884,7 +965,8 @@ addFingerprints hsc_env iface0
-- when calculating fingerprints, we always need to use canonical
-- ordering for lists of things. In particular, the mi_deps has various
-- lists of modules and suchlike, so put these all in canonical order:
- let sorted_deps = sortDependencies (mi_deps iface0)
+ let sorted_deps :: Dependencies
+ sorted_deps = sortDependencies (mi_deps iface0)
-- The export hash of a module depends on the orphan hashes of the
-- orphan modules below us in the dependency tree. This is the way
@@ -971,7 +1053,8 @@ addFingerprints hsc_env iface0
--
-- put the declarations in a canonical order, sorted by OccName
- let sorted_decls = Map.elems $ Map.fromList $
+ let sorted_decls :: [(Fingerprint, IfaceDecl)]
+ sorted_decls = Map.elems $ Map.fromList $
[(getOccName d, e) | e@(_, d) <- decls_w_hashes]
-- the flag hash depends on:
=====================================
includes/RtsAPI.h
=====================================
@@ -58,6 +58,9 @@ typedef struct CapabilityPublic_ {
StgRegTable r;
} CapabilityPublic;
+/* N.B. this needs the Capability declaration above. */
+#include "rts/EventLogWriter.h"
+
/* ----------------------------------------------------------------------------
RTS configuration settings, for passing to hs_init_ghc()
------------------------------------------------------------------------- */
@@ -566,6 +569,16 @@ void rts_resume (PauseToken *pauseToken);
// Returns true if the rts is paused. See rts_pause() and rts_resume().
bool rts_isPaused(void);
+// List all live threads. The RTS must be paused and this must be called on the
+// same thread that called rts_pause().
+typedef void (*ListThreadsCb)(void *user, StgTSO *);
+void rts_listThreads(ListThreadsCb cb, void *user);
+
+// List all non-thread GC roots. The RTS must be paused and this must be called
+// on the same thread that called rts_pause().
+typedef void (*ListRootsCb)(void *user, StgClosure *);
+void rts_listMiscRoots(ListRootsCb cb, void *user);
+
/*
* The RTS allocates some thread-local data when you make a call into
* Haskell using one of the rts_eval() functions. This data is not
=====================================
includes/rts/EventLogWriter.h
=====================================
@@ -68,3 +68,8 @@ bool startEventLogging(const EventLogWriter *writer);
* Stop event logging and destroy the current EventLogWriter.
*/
void endEventLogging(void);
+
+/*
+ * Flush the eventlog. cap can be NULL if one is not held.
+ */
+void flushEventLog(Capability **cap);
=====================================
libraries/base/Debug/Trace.hs
=====================================
@@ -37,6 +37,7 @@ module Debug.Trace (
-- $eventlog_tracing
traceEvent,
traceEventIO,
+ flushEventLog,
-- * Execution phase markers
-- $markers
@@ -319,3 +320,11 @@ traceMarkerIO :: String -> IO ()
traceMarkerIO msg =
GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
case traceMarker# p s of s' -> (# s', () #)
+
+-- | Immediately flush the event log, if enabled.
+--
+-- @since 4.15.0.0
+flushEventLog :: IO ()
+flushEventLog = c_flushEventLog nullPtr
+
+foreign import ccall "flushEventLog" c_flushEventLog :: Ptr () -> IO ()
=====================================
rts/Capability.c
=====================================
@@ -23,6 +23,7 @@
#include "Schedule.h"
#include "Sparks.h"
#include "Trace.h"
+#include "eventlog/EventLog.h" // for flushLocalEventsBuf
#include "sm/GC.h" // for gcWorkerThread()
#include "STM.h"
#include "RtsUtils.h"
@@ -982,6 +983,10 @@ yieldCapability
debugTrace(DEBUG_nonmoving_gc, "Flushing update remembered set blocks...");
break;
+ case SYNC_FLUSH_EVENT_LOG:
+ flushLocalEventsBuf(cap);
+ break;
+
default:
break;
}
=====================================
rts/Capability.h
=====================================
@@ -267,7 +267,8 @@ typedef enum {
SYNC_OTHER,
SYNC_GC_SEQ,
SYNC_GC_PAR,
- SYNC_FLUSH_UPD_REM_SET
+ SYNC_FLUSH_UPD_REM_SET,
+ SYNC_FLUSH_EVENT_LOG
} SyncType;
//
=====================================
rts/RtsAPI.c
=====================================
@@ -15,6 +15,7 @@
#include "Prelude.h"
#include "Schedule.h"
#include "Capability.h"
+#include "StableName.h"
#include "StablePtr.h"
#include "Threads.h"
#include "Weak.h"
@@ -809,6 +810,46 @@ static void assert_isPausedOnMyTask(const char *functionName)
}
}
+// See RtsAPI.h
+void rts_listThreads(ListThreadsCb cb, void *user)
+{
+ assert_isPausedOnMyTask("rts_listThreads");
+
+ // The rts is paused and can only be resumed by the current thread. Hence it
+ // is safe to read global thread data.
+
+ for (uint32_t g=0; g < RtsFlags.GcFlags.generations; g++) {
+ StgTSO *tso = generations[g].threads;
+ while (tso != END_TSO_QUEUE) {
+ cb(user, tso);
+ tso = tso->global_link;
+ }
+ }
+}
+
+struct list_roots_ctx {
+ ListRootsCb cb;
+ void *user;
+};
+
+// This is an evac_fn.
+static void list_roots_helper(void *user, StgClosure **p) {
+ struct list_roots_ctx *ctx = (struct list_roots_ctx *) user;
+ ctx->cb(ctx->user, *p);
+}
+
+// See RtsAPI.h
+void rts_listMiscRoots (ListRootsCb cb, void *user)
+{
+ assert_isPausedOnMyTask("rts_listMiscRoots");
+
+ struct list_roots_ctx ctx;
+ ctx.cb = cb;
+ ctx.user = user;
+
+ threadStableNameTable(&list_roots_helper, (void *)&ctx);
+ threadStablePtrTable(&list_roots_helper, (void *)&ctx);
+}
#else
PauseToken GNU_ATTRIBUTE(__noreturn__)
@@ -833,6 +874,18 @@ bool rts_isPaused()
"multithreaded RTS.");
return false;
}
+
+// See RtsAPI.h
+void rts_listThreads(ListThreadsCb cb STG_UNUSED, void *user STG_UNUSED)
+{
+ errorBelch("Warning: rts_listThreads is only possible for multithreaded RTS.");
+}
+
+// See RtsAPI.h
+void rts_listMiscRoots (ListRootsCb cb STG_UNUSED, void *user STG_UNUSED)
+{
+ errorBelch("Warning: rts_listMiscRoots is only possible for multithreaded RTS.");
+}
#endif
void rts_done (void)
=====================================
rts/RtsSymbols.c
=====================================
@@ -594,6 +594,7 @@
SymI_HasProto(__word_encodeFloat) \
SymI_HasProto(stg_atomicallyzh) \
SymI_HasProto(barf) \
+ SymI_HasProto(flushEventLog) \
SymI_HasProto(deRefStablePtr) \
SymI_HasProto(debugBelch) \
SymI_HasProto(errorBelch) \
=====================================
rts/Schedule.c
=====================================
@@ -2070,7 +2070,7 @@ forkProcess(HsStablePtr *entry
stopTimer(); // See #4074
#if defined(TRACING)
- flushEventLog(); // so that child won't inherit dirty file buffers
+ flushAllCapsEventsBufs(); // so that child won't inherit dirty file buffers
#endif
pid = fork();
=====================================
rts/Trace.c
=====================================
@@ -118,10 +118,10 @@ void resetTracing (void)
restartEventLogging();
}
-void flushTrace (void)
+void flushTrace ()
{
if (eventlog_enabled) {
- flushEventLog();
+ flushEventLog(NULL);
}
}
=====================================
rts/Trace.h
=====================================
@@ -319,7 +319,6 @@ void traceConcSweepEnd(void);
void traceConcUpdRemSetFlush(Capability *cap);
void traceNonmovingHeapCensus(uint32_t log_blk_size,
const struct NonmovingAllocCensus *census);
-
void flushTrace(void);
#else /* !TRACING */
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -16,6 +16,7 @@
#include "RtsUtils.h"
#include "Stats.h"
#include "EventLog.h"
+#include "Schedule.h"
#include <string.h>
#include <stdio.h>
@@ -270,8 +271,8 @@ stopEventLogWriter(void)
}
}
-void
-flushEventLog(void)
+static void
+flushEventLogWriter(void)
{
if (event_log_writer != NULL &&
event_log_writer->flushEventLog != NULL) {
@@ -1484,7 +1485,7 @@ void printAndClearEventBuf (EventsBuf *ebuf)
"printAndClearEventLog: could not flush event log\n"
);
resetEventsBuf(ebuf);
- flushEventLog();
+ flushEventLogWriter();
return;
}
@@ -1566,6 +1567,40 @@ void postEventType(EventsBuf *eb, EventType *et)
postInt32(eb, EVENT_ET_END);
}
+void flushLocalEventsBuf(Capability *cap)
+{
+ EventsBuf *eb = &capEventBuf[cap->no];
+ printAndClearEventBuf(eb);
+}
+
+// Flush all capabilities' event buffers when we already hold all capabilities.
+// Used during forkProcess.
+void flushAllCapsEventsBufs()
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+ printAndClearEventBuf(&eventBuf);
+ RELEASE_LOCK(&eventBufMutex);
+
+ for (unsigned int i=0; i < n_capabilities; i++) {
+ flushLocalEventsBuf(capabilities[i]);
+ }
+ flushEventLogWriter();
+}
+
+void flushEventLog(Capability **cap USED_IF_THREADS)
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+ printAndClearEventBuf(&eventBuf);
+ RELEASE_LOCK(&eventBufMutex);
+
+#if defined(THREADED_RTS)
+ Task *task = getMyTask();
+ stopAllCapabilitiesWith(cap, task, SYNC_FLUSH_EVENT_LOG);
+ releaseAllCapabilities(n_capabilities, cap ? *cap : NULL, task);
+#endif
+ flushEventLogWriter();
+}
+
#else
enum EventLogStatus eventLogStatus(void)
@@ -1579,4 +1614,6 @@ bool startEventLogging(const EventLogWriter *writer STG_UNUSED) {
void endEventLogging(void) {}
+void flushEventLog(Capability **cap STG_UNUSED) {}
+
#endif /* TRACING */
=====================================
rts/eventlog/EventLog.h
=====================================
@@ -28,8 +28,10 @@ void initEventLogging(void);
void restartEventLogging(void);
void freeEventLogging(void);
void abortEventLogging(void); // #4512 - after fork child needs to abort
-void flushEventLog(void); // event log inherited from parent
void moreCapEventBufs (uint32_t from, uint32_t to);
+void flushLocalEventsBuf(Capability *cap);
+void flushAllCapsEventsBufs(void);
+void flushAllEventsBufs(Capability *cap);
/*
* Post a scheduler event to the capability's event buffer (an event
@@ -175,6 +177,9 @@ void postNonmovingHeapCensus(int log_blk_size,
#else /* !TRACING */
+INLINE_HEADER void flushLocalEventsBuf(Capability *cap STG_UNUSED)
+{ /* nothing */ }
+
INLINE_HEADER void postSchedEvent (Capability *cap STG_UNUSED,
EventTypeNum tag STG_UNUSED,
StgThreadID id STG_UNUSED,
=====================================
testsuite/tests/arityanal/should_compile/T18870.hs
=====================================
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+module T18870 where
+
+import GHC.Exts
+
+-- This function should not lead to an "Exciting arity" DEBUG message.
+-- It should only do one round of fixed-point iteration to conclude that it has
+-- arity 2.
+f :: [a] -> a -> a
+f [] = id
+f (x:xs) = oneShot (\_ -> f xs x)
=====================================
testsuite/tests/arityanal/should_compile/T18937.hs
=====================================
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+module T18937 where
+
+f :: [Int] -> Int -> Int
+f [] = id
+f (x:xs) = let y = sum [0..x]
+ in \z -> f xs (y + z)
=====================================
testsuite/tests/arityanal/should_compile/all.T
=====================================
@@ -19,3 +19,5 @@ test('Arity16', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dn
# Regression tests
test('T18793', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques'])
+test('T18870', [ only_ways(['optasm']) ], compile, ['-ddebug-output'])
+test('T18937', [ only_ways(['optasm']) ], compile, ['-ddebug-output'])
=====================================
testsuite/tests/driver/T18733/Library1.hs
=====================================
@@ -0,0 +1,7 @@
+module Library where
+
+data A = ARecu B | ABase String deriving (Show)
+data B = BRecu A | BBase Int deriving (Show)
+
+info :: B
+info = BBase 1
=====================================
testsuite/tests/driver/T18733/Library2.hs
=====================================
@@ -0,0 +1,7 @@
+module Library where
+
+data A = ARecu B | ABase String deriving (Show)
+data B = BRecu A | BBase Int deriving (Show)
+
+info :: A
+info = ABase "Hello"
=====================================
testsuite/tests/driver/T18733/Main.hs
=====================================
@@ -0,0 +1,5 @@
+module Main where
+
+import Library
+
+main = putStrLn $ show info
=====================================
testsuite/tests/driver/T18733/Makefile
=====================================
@@ -0,0 +1,12 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T18733:
+ cp Library1.hs Library.hs
+ '$(TEST_HC)' -v0 -o Main Library.hs Main.hs
+ ./Main
+
+ cp Library2.hs Library.hs
+ '$(TEST_HC)' -v0 -o Main Library.hs Main.hs
+ ./Main
=====================================
testsuite/tests/driver/T18733/T18733.stdout
=====================================
@@ -0,0 +1,2 @@
+BBase 1
+ABase "Hello"
=====================================
testsuite/tests/driver/T18733/all.T
=====================================
@@ -0,0 +1,2 @@
+srcs = ['Library1.hs', 'Library2.hs', 'Main.hs']
+test('T18733', extra_files(srcs), makefile_test, [])
=====================================
testsuite/tests/rts/pause-resume/all.T
=====================================
@@ -18,3 +18,8 @@ test('pause_and_use_rts_api',
, extra_files(['pause_resume.c','pause_resume.h'])
],
multi_compile_and_run, ['pause_and_use_rts_api', [('pause_resume.c','')], ''])
+test('list_threads_and_misc_roots',
+ [ only_ways(['threaded1', 'threaded2'])
+ , extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h'])
+ ],
+ multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], ''])
\ No newline at end of file
=====================================
testsuite/tests/rts/pause-resume/list_threads_and_misc_roots.hs
=====================================
@@ -0,0 +1,6 @@
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h checkGcRoots"
+ checkGcRoots :: IO ()
+
+main :: IO ()
+main = checkGcRoots
=====================================
testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.c
=====================================
@@ -0,0 +1,54 @@
+
+#include "list_threads_and_misc_roots_c.h"
+
+static int tsoCount = 0;
+static StgTSO** tsos;
+
+static int miscRootsCount = 0;
+static StgClosure** miscRoots;
+
+void collectTSOsCallback(void *user, StgTSO* tso){
+ tsoCount++;
+ tsos = realloc(tsos, sizeof(StgTSO*) * tsoCount);
+ tsos[tsoCount - 1] = tso;
+}
+
+void collectMiscRootsCallback(void *user, StgClosure* closure){
+ miscRootsCount++;
+ miscRoots = realloc(miscRoots, sizeof(StgClosure*) * miscRootsCount);
+ miscRoots[miscRootsCount - 1] = closure;
+}
+
+void checkGcRoots(void)
+{
+ PauseToken * token = rts_pause();
+
+ // Check TSO collection.
+ rts_listThreads(&collectTSOsCallback, NULL);
+ for (int i = 0; i < tsoCount; i++)
+ {
+ StgTSO *tso = UNTAG_CLOSURE(tsos[i]);
+ if (get_itbl(tso)->type != TSO)
+ {
+ fprintf(stderr, "tso returned a non-TSO type %zu at index %i\n",
+ tso->header.info->type,
+ i);
+ exit(1);
+ }
+ }
+
+ // Check misc GC roots collection.
+ rts_listMiscRoots(&collectMiscRootsCallback, NULL);
+ for (int i = 0; i < miscRootsCount; i++)
+ {
+ StgClosure *root = UNTAG_CLOSURE(miscRoots[i]);
+ if (get_itbl(root)->type == TSO)
+ {
+ fprintf(stderr, "rts_listThreads unexpectedly returned an TSO type at index %i (TSO=%zu)\n", i, TSO);
+ exit(1);
+ }
+ }
+
+
+ rts_resume(token);
+}
=====================================
testsuite/tests/rts/pause-resume/list_threads_and_misc_roots_c.h
=====================================
@@ -0,0 +1,5 @@
+
+#include "Rts.h"
+#include "RtsAPI.h"
+
+void checkGcRoots(void);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0909c9a8242aa2928ccf59c207c9315aaec8a3f...aaaa833b4d1db288b357f6c1c4bea34a6636f5bf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0909c9a8242aa2928ccf59c207c9315aaec8a3f...aaaa833b4d1db288b357f6c1c4bea34a6636f5bf
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/20201114/c417f456/attachment-0001.html>
More information about the ghc-commits
mailing list