[Git][ghc/ghc][ghc-9.6] 15 commits: upload_ghc_libs: More control over which packages to operate on
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Thu Jan 19 01:11:25 UTC 2023
Ben Gamari pushed to branch ghc-9.6 at Glasgow Haskell Compiler / GHC
Commits:
fd42d718 by Ben Gamari at 2023-01-17T18:36:22-05:00
upload_ghc_libs: More control over which packages to operate on
Here we add a `--skip` flag to `upload_ghc_libs`, making it easier to
limit which packages to upload. This is often necessary when one package
is not uploadable (e.g. see #22740).
- - - - -
67dabd44 by Simon Peyton Jones at 2023-01-17T18:39:18-05:00
Fix void-arg-adding mechanism for worker/wrapper
As #22725 shows, in worker/wrapper we must add the void argument
/last/, not first. See GHC.Core.Opt.WorkWrap.Utils
Note [Worker/wrapper needs to add void arg last].
That led me to to study GHC.Core.Opt.SpecConstr
Note [SpecConstr needs to add void args first] which suggests the
opposite! And indeed I think it's the other way round for SpecConstr
-- or more precisely the void arg must precede the "extra_bndrs".
That led me to some refactoring of GHC.Core.Opt.SpecConstr.calcSpecInfo.
(cherry picked from commit 964284fcab6e27fe2fa5c279ea008551cbc15dbb)
- - - - -
8a536475 by Simon Peyton Jones at 2023-01-17T18:40:58-05:00
Add a missing checkEscapingKind
Ticket #22743 pointed out that there is a missing check,
for type-inferred bindings, that the inferred type doesn't
have an escaping kind.
The fix is easy.
(cherry picked from commit 496607fdb77baf12e2fe263104ba5d0d700eee3b)
- - - - -
ee450fb1 by Simon Peyton Jones at 2023-01-17T18:41:22-05:00
Make FloatIn robust to shadowing
This MR fixes #22622. See the new
Note [Shadowing and name capture]
I did a bit of refactoring in sepBindsByDropPoint too.
The bug doesn't manifest in HEAD, but it did show up in 9.4,
so we should backport this patch to 9.4
(cherry picked from commit 6206cb9287f3f6e70c669660a646a65274870d2b)
- - - - -
5107c031 by Viktor Dukhovni at 2023-01-17T18:41:30-05:00
Avoid unnecessary printf warnings in EventLog.c
Fixes #22778
(cherry picked from commit fc02f3bbb5f47f880465e22999ba9794f658d8f6)
- - - - -
d1a59401 by Bodigrim at 2023-01-17T18:41:42-05:00
Bump submodule parsec to 3.1.16.1
(cherry picked from commit 97bd4d8c03fe74a7642f617db12bbee2215e24e6)
- - - - -
75e879b6 by Ben Gamari at 2023-01-17T18:41:51-05:00
gitlab-ci: Bump Darwin bootstrap toolchain
This updates the bootstrap compiler on Darwin from 8.10.7 to 9.2.5,
ensuring that we have the fix for #21964.
(cherry picked from commit df33c13c802cdb846e1377e61bebaebe8955ff15)
- - - - -
a3cdfa96 by Ben Gamari at 2023-01-17T18:41:53-05:00
gitlab-ci: Pass -w to cabal update
Due to cabal#8447, cabal-install 3.8.1.0 requires a compiler to run
`cabal update`.
(cherry picked from commit 756a66ec0875b675bd3256d46d57419827312426)
- - - - -
cd3339e1 by Bodigrim at 2023-01-17T18:42:01-05:00
Bump submodule bytestring to 0.11.4.0
Metric Decrease:
T21839c
T21839r
(cherry picked from commit 9a3d6add05d9227fb047cf6ce7ae35dc11c51718)
- - - - -
82a4c5ad by Andreas Klebinger at 2023-01-17T18:42:19-05:00
Only gc sparks locally when we can ensure marking is done.
When performing GC without work stealing there was no guarantee that
spark pruning was happening after marking of the sparks. This could
cause us to GC live sparks under certain circumstances.
Fixes #22528.
(cherry picked from commit a1491c8791c57a64d94bc08d639d585815c8d4e2)
- - - - -
dd1df967 by Ben Gamari at 2023-01-17T18:43:39-05:00
configure: Fix escaping of `$tooldir`
In !9547 I introduced `$tooldir` directories into GHC's default link and
compilation flags to ensure that our C toolchain finds its own headers
and libraries before others on the system. However, the patch was subtly
wrong in the escaping of `$tooldir`. Fix this.
Fixes #22561.
(cherry picked from commit 9ffd5d57a7cc19bcd6ea0139b00c77639566ba82)
- - - - -
1b9fec7a by Ben Gamari at 2023-01-17T18:43:49-05:00
Revert "rts: Drop racy assertion"
The logic here was inverted. Reverting the commit to avoid confusion
when examining the commit history.
This reverts commit b3eacd64fb36724ed6c5d2d24a81211a161abef1.
(cherry picked from commit db11f3586085901e89705f69aff472e027c0748f)
- - - - -
76738aeb by Ben Gamari at 2023-01-17T18:43:49-05:00
rts: Drop racy assertion
0e274c39bf836d5bb846f5fa08649c75f85326ac added an assertion in
`dirty_MUT_VAR` checking that the MUT_VAR being dirtied was clean.
However, this isn't necessarily the case since another thread may have
raced us to dirty the object.
(cherry picked from commit 3242139fbd18df324460e22619c1a1fb3b258a07)
- - - - -
a886fcc8 by Sebastian Graf at 2023-01-18T12:30:25-05:00
Handle shadowing in DmdAnal (#22718)
Previously, when we had a shadowing situation like
```hs
f x = ... -- demand signature <1L><1L>
main = ... \f -> f 1 ...
```
we'd happily use the shadowed demand signature at the call site inside the
lambda. Of course, that's wrong and solution is simply to remove the demand
signature from the `AnalEnv` when we enter the lambda.
This patch does so for all binding constructs Core.
In #22718 the issue was caused by LetUp not shadowing away the existing demand
signature for the let binder in the let body. The resulting absent error is
fickle to reproduce; hence no reproduction test case. #17478 would help.
Fixes #22718.
It appears that TcPlugin_Rewrite regresses by ~40% on Darwin. It is likely that
DmdAnal was exploiting ill-scoped analysis results.
Metric increase ['bytes allocated'] (test_env=x86_64-darwin-validate):
TcPlugin_Rewrite
(cherry picked from commit e3fff7512bbf989386faaa1dccafdad1deabde84)
- - - - -
991b9ca5 by Ben Gamari at 2023-01-18T12:31:21-05:00
Accept performance metric changes
Metric Decrease:
MultiLayerModulesTH_OneShot
T21839c
T21839r
- - - - -
30 changed files:
- .gitlab/ci.sh
- .gitlab/darwin/nix/sources.json
- .gitlab/darwin/toolchain.nix
- .gitlab/upload_ghc_libs.py
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Validity.hs
- docs/users_guide/9.6.1-notes.rst
- libraries/bytestring
- libraries/parsec
- m4/fp_settings.m4
- rts/Sparks.c
- rts/eventlog/EventLog.c
- rts/sm/GC.c
- rts/sm/Storage.c
- testsuite/tests/ghci/scripts/T9881.stdout
- testsuite/tests/ghci/scripts/ghci025.stdout
- + testsuite/tests/polykinds/T22743.hs
- + testsuite/tests/polykinds/T22743.stderr
- testsuite/tests/polykinds/all.T
- testsuite/tests/simplCore/should_compile/T13143.stderr
- testsuite/tests/simplCore/should_compile/T18328.stderr
- + testsuite/tests/simplCore/should_compile/T22662.hs
- + testsuite/tests/simplCore/should_compile/T22725.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -240,7 +240,9 @@ function set_toolchain_paths() {
}
function cabal_update() {
- run "$CABAL" update --index="$HACKAGE_INDEX_STATE"
+ # In principle -w shouldn't be necessary here but with
+ # cabal-install 3.8.1.0 it is, due to cabal#8447.
+ run "$CABAL" update -w "$GHC" --index="$HACKAGE_INDEX_STATE"
}
=====================================
.gitlab/darwin/nix/sources.json
=====================================
@@ -12,15 +12,15 @@
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixpkgs": {
- "branch": "wip/ghc-8.10.7-darwin",
+ "branch": "master",
"description": "Nix Packages collection",
"homepage": "",
- "owner": "bgamari",
+ "owner": "nixos",
"repo": "nixpkgs",
- "rev": "37c60356e3f83c708a78a96fdd914b5ffc1f551c",
- "sha256": "0i5j7nwk4ky0fg4agla3aznadpxz0jyrdwp2q92hyxidra987syn",
+ "rev": "ce1aa29621356706746c53e2d480da7c68f6c972",
+ "sha256": "sha256:1sbs3gi1nf4rcbmnw69fw0fpvb3qvlsa84hqimv78vkpd6xb0bgg",
"type": "tarball",
- "url": "https://github.com/bgamari/nixpkgs/archive/37c60356e3f83c708a78a96fdd914b5ffc1f551c.tar.gz",
+ "url": "https://github.com/nixos/nixpkgs/archive/ce1aa29621356706746c53e2d480da7c68f6c972.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}
=====================================
.gitlab/darwin/toolchain.nix
=====================================
@@ -15,16 +15,16 @@ let
ghcBindists = let version = ghc.version; in {
aarch64-darwin = pkgs.fetchurl {
url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-aarch64-apple-darwin.tar.xz";
- sha256 = "sha256:10pby1idpxhkjqsi56jivkymhnabsdr8m2x8gdqchnv5113hl72k";
+ sha256 = "sha256-tQUHsingxBizLktswGAoi6lJf92RKWLjsHB9CisANlg=";
};
x86_64-darwin = pkgs.fetchurl {
url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-x86_64-apple-darwin.tar.xz";
- sha256 = "sha256:012yzyangk26sdapnz4226prgb8jgpf6k5bd9qxsdykk5x7jc7ah";
+ sha256 = "sha256-OjXjVe+ZODDCc/hqtihqqz6CX25TKI0ZgORzkR5O3pQ=";
};
};
ghc = pkgs.stdenv.mkDerivation rec {
- version = "9.4.3";
+ version = "9.4.4";
name = "ghc";
src = ghcBindists.${pkgs.stdenv.hostPlatform.system};
configureFlags = [
=====================================
.gitlab/upload_ghc_libs.py
=====================================
@@ -197,19 +197,23 @@ def main() -> None:
parser_prepare.add_argument('--bindist', required=True, type=Path, help='extracted binary distribution')
parser_upload = subparsers.add_parser('upload')
+ parser_upload.add_argument('--skip', nargs='*', type=str, help='skip uploading of the given package')
parser_upload.add_argument('--docs', required = True, type=Path, help='folder created by --prepare')
parser_upload.add_argument('--publish', action='store_true', help='Publish Hackage packages instead of just uploading candidates')
args = parser.parse_args()
- pkgs = args.pkg
+ pkgs = set(args.pkg)
for pkg_name in pkgs:
assert pkg_name in PACKAGES
- if pkgs == []:
- pkgs = PACKAGES.keys()
+ if not pkgs:
+ pkgs = set(PACKAGES.keys())
- if args.command == "prepare":
+ for pkg_name in args.skip:
+ assert pkg_name in PACKAGES
+ pkgs = pkgs - args.skip
+ if args.command == "prepare":
manifest = {}
for pkg_name in pkgs:
print(pkg_name)
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -35,9 +35,12 @@ import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Utils.Misc
-import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import GHC.Utils.Outputable
+
+import Data.List ( mapAccumL )
+
{-
Top-level interface function, @floatInwards at . Note that we do not
actually float any bindings downwards from the top-level.
@@ -124,7 +127,7 @@ the closure for a is not built.
************************************************************************
-}
-type FreeVarSet = DIdSet
+type FreeVarSet = DVarSet
type BoundVarSet = DIdSet
data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
@@ -132,11 +135,17 @@ data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
-- of recursive bindings, the set doesn't include the bound
-- variables.
-type FloatInBinds = [FloatInBind]
- -- In reverse dependency order (innermost binder first)
+type FloatInBinds = [FloatInBind] -- In normal dependency order
+ -- (outermost binder first)
+type RevFloatInBinds = [FloatInBind] -- In reverse dependency order
+ -- (innermost binder first)
+
+instance Outputable FloatInBind where
+ ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs
+ , text "fvs =" <+> ppr fvs ])
fiExpr :: Platform
- -> FloatInBinds -- Binds we're trying to drop
+ -> RevFloatInBinds -- Binds we're trying to drop
-- as far "inwards" as possible
-> CoreExprWithFVs -- Input expr
-> CoreExpr -- Result
@@ -147,13 +156,12 @@ fiExpr _ to_drop (_, AnnType ty) = assert (null to_drop) $ Type ty
fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v)
fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
fiExpr platform to_drop (_, AnnCast expr (co_ann, co))
- = wrapFloats (drop_here ++ co_drop) $
+ = wrapFloats drop_here $
Cast (fiExpr platform e_drop expr) co
where
- [drop_here, e_drop, co_drop]
- = sepBindsByDropPoint platform False
- [freeVarsOf expr, freeVarsOfAnn co_ann]
- to_drop
+ (drop_here, [e_drop])
+ = sepBindsByDropPoint platform False to_drop
+ (freeVarsOfAnn co_ann) [freeVarsOf expr]
{-
Applications: we do float inside applications, mainly because we
@@ -162,7 +170,7 @@ pull out any silly ones.
-}
fiExpr platform to_drop ann_expr@(_,AnnApp {})
- = wrapFloats drop_here $ wrapFloats extra_drop $
+ = wrapFloats drop_here $
mkTicks ticks $
mkApps (fiExpr platform fun_drop ann_fun)
(zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)
@@ -170,21 +178,19 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {})
-- length ann_args = length arg_fvs = length arg_drops
where
(ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
- fun_ty = exprType (deAnnotate ann_fun)
fun_fvs = freeVarsOf ann_fun
- arg_fvs = map freeVarsOf ann_args
- (drop_here : extra_drop : fun_drop : arg_drops)
- = sepBindsByDropPoint platform False
- (extra_fvs : fun_fvs : arg_fvs)
- to_drop
+ (drop_here, fun_drop : arg_drops)
+ = sepBindsByDropPoint platform False to_drop
+ here_fvs (fun_fvs : arg_fvs)
+
-- Shortcut behaviour: if to_drop is empty,
-- sepBindsByDropPoint returns a suitable bunch of empty
-- lists without evaluating extra_fvs, and hence without
-- peering into each argument
- (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args
- extra_fvs0 = case ann_fun of
+ (here_fvs, arg_fvs) = mapAccumL add_arg here_fvs0 ann_args
+ here_fvs0 = case ann_fun of
(_, AnnVar _) -> fun_fvs
_ -> emptyDVarSet
-- Don't float the binding for f into f x y z; see Note [Join points]
@@ -192,14 +198,11 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {})
-- join point, floating it in isn't especially harmful but it's
-- useless since the simplifier will immediately float it back out.)
- add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)
- add_arg (fun_ty, extra_fvs) (_, AnnType ty)
- = (piResultTy fun_ty ty, extra_fvs)
- add_arg (fun_ty, extra_fvs) (arg_fvs, arg)
- | noFloatIntoArg arg
- = (funResultTy fun_ty, extra_fvs `unionDVarSet` arg_fvs)
- | otherwise
- = (funResultTy fun_ty, extra_fvs)
+ add_arg :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet)
+ -- We can't float into some arguments, so put them into the here_fvs
+ add_arg here_fvs (arg_fvs, arg)
+ | noFloatIntoArg arg = (here_fvs `unionDVarSet` arg_fvs, emptyDVarSet)
+ | otherwise = (here_fvs, arg_fvs)
{- Note [Dead bindings]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -272,7 +275,6 @@ it's non-recursive, so we float only into non-recursive join points.)
Urk! if all are tyvars, and we don't float in, we may miss an
opportunity to float inside a nested case branch
-
Note [Floating coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~
We could, in principle, have a coercion binding like
@@ -292,6 +294,36 @@ of the types of all the drop points involved. If any of the floaters
bind a coercion variable mentioned in any of the types, that binder must
be dropped right away.
+Note [Shadowing and name capture]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ let x = y+1 in
+ case p of
+ (y:ys) -> ...x...
+ [] -> blah
+It is obviously bogus for FloatIn to transform to
+ case p of
+ (y:ys) -> ...(let x = y+1 in x)...
+ [] -> blah
+because the y is captured. This doesn't happen much, because shadowing is
+rare, but it did happen in #22662.
+
+One solution would be to clone as we go. But a simpler one is this:
+
+ at a binding site (like that for (y:ys) above), abandon float-in for
+ any floating bindings that mention the binders (y, ys in this case)
+
+We achieve that by calling sepBindsByDropPoint with the binders in
+the "used-here" set:
+
+* In fiExpr (AnnLam ...). For the body there is no need to delete
+ the lambda-binders from the body_fvs, because any bindings that
+ mention these binders will be dropped here anyway.
+
+* In fiExpr (AnnCase ...). Remember to include the case_bndr in the
+ binders. Again, no need to delete the alt binders from the rhs
+ free vars, beause any bindings mentioning them will be dropped
+ here unconditionally.
-}
fiExpr platform to_drop lam@(_, AnnLam _ _)
@@ -300,10 +332,17 @@ fiExpr platform to_drop lam@(_, AnnLam _ _)
= wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))
| otherwise -- Float inside
- = mkLams bndrs (fiExpr platform to_drop body)
+ = wrapFloats drop_here $
+ mkLams bndrs (fiExpr platform body_drop body)
where
(bndrs, body) = collectAnnBndrs lam
+ body_fvs = freeVarsOf body
+
+ -- Why sepBindsByDropPoint? Because of potential capture
+ -- See Note [Shadowing and name capture]
+ (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop
+ (mkDVarSet bndrs) [body_fvs]
{-
We don't float lets inwards past an SCC.
@@ -443,16 +482,16 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]
= wrapFloats shared_binds $
fiExpr platform (case_float : rhs_binds) rhs
where
- case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
+ case_float = FB all_bndrs scrut_fvs
(FloatCase scrut' case_bndr con alt_bndrs)
scrut' = fiExpr platform scrut_binds scrut
- rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
- scrut_fvs = freeVarsOf scrut
+ rhs_fvs = freeVarsOf rhs -- No need to delete alt_bndrs
+ scrut_fvs = freeVarsOf scrut -- See Note [Shadowing and name capture]
+ all_bndrs = mkDVarSet alt_bndrs `extendDVarSet` case_bndr
- [shared_binds, scrut_binds, rhs_binds]
- = sepBindsByDropPoint platform False
- [scrut_fvs, rhs_fvs]
- to_drop
+ (shared_binds, [scrut_binds, rhs_binds])
+ = sepBindsByDropPoint platform False to_drop
+ all_bndrs [scrut_fvs, rhs_fvs]
fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
= wrapFloats drop_here1 $
@@ -462,39 +501,43 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
-- use zipWithEqual, we should have length alts_drops_s = length alts
where
-- Float into the scrut and alts-considered-together just like App
- [drop_here1, scrut_drops, alts_drops]
- = sepBindsByDropPoint platform False
- [scrut_fvs, all_alts_fvs]
- to_drop
+ (drop_here1, [scrut_drops, alts_drops])
+ = sepBindsByDropPoint platform False to_drop
+ all_alt_bndrs [scrut_fvs, all_alt_fvs]
+ -- all_alt_bndrs: see Note [Shadowing and name capture]
-- Float into the alts with the is_case flag set
- (drop_here2 : alts_drops_s)
- | [ _ ] <- alts = [] : [alts_drops]
- | otherwise = sepBindsByDropPoint platform True alts_fvs alts_drops
-
- scrut_fvs = freeVarsOf scrut
- alts_fvs = map alt_fvs alts
- all_alts_fvs = unionDVarSets alts_fvs
- alt_fvs (AnnAlt _con args rhs)
- = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
- -- Delete case_bndr and args from free vars of rhs
- -- to get free vars of alt
+ (drop_here2, alts_drops_s)
+ = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs
+
+ scrut_fvs = freeVarsOf scrut
+
+ all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) (unitDVarSet case_bndr) alts
+ ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs
+
+ alts_fvs :: [DVarSet]
+ alts_fvs = [freeVarsOf rhs | AnnAlt _ _ rhs <- alts]
+ -- No need to delete binders
+ -- See Note [Shadowing and name capture]
+
+ all_alt_fvs :: DVarSet
+ all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs
fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)
------------------
fiBind :: Platform
- -> FloatInBinds -- Binds we're trying to drop
- -- as far "inwards" as possible
- -> CoreBindWithFVs -- Input binding
- -> DVarSet -- Free in scope of binding
- -> ( FloatInBinds -- Land these before
- , FloatInBind -- The binding itself
- , FloatInBinds) -- Land these after
+ -> RevFloatInBinds -- Binds we're trying to drop
+ -- as far "inwards" as possible
+ -> CoreBindWithFVs -- Input binding
+ -> DVarSet -- Free in scope of binding
+ -> ( RevFloatInBinds -- Land these before
+ , FloatInBind -- The binding itself
+ , RevFloatInBinds) -- Land these after
fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
- = ( extra_binds ++ shared_binds -- Land these before
- -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]
+ = ( shared_binds -- Land these before
+ -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]
, FB (unitDVarSet id) rhs_fvs' -- The new binding itself
(FloatLet (NonRec id rhs'))
, body_binds ) -- Land these after
@@ -512,10 +555,9 @@ fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
-- We *can't* float into ok-for-speculation unlifted RHSs
-- But do float into join points
- [shared_binds, extra_binds, rhs_binds, body_binds]
- = sepBindsByDropPoint platform False
- [extra_fvs, rhs_fvs, body_fvs2]
- to_drop
+ (shared_binds, [rhs_binds, body_binds])
+ = sepBindsByDropPoint platform False to_drop
+ extra_fvs [rhs_fvs, body_fvs2]
-- Push rhs_binds into the right hand side of the binding
rhs' = fiRhs platform rhs_binds id ann_rhs
@@ -523,7 +565,7 @@ fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
-- Don't forget the rule_fvs; the binding mentions them!
fiBind platform to_drop (AnnRec bindings) body_fvs
- = ( extra_binds ++ shared_binds
+ = ( shared_binds
, FB (mkDVarSet ids) rhs_fvs'
(FloatLet (Rec (fi_bind rhss_binds bindings)))
, body_binds )
@@ -537,17 +579,16 @@ fiBind platform to_drop (AnnRec bindings) body_fvs
unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
, noFloatIntoRhs Recursive bndr rhs ]
- (shared_binds:extra_binds:body_binds:rhss_binds)
- = sepBindsByDropPoint platform False
- (extra_fvs:body_fvs:rhss_fvs)
- to_drop
+ (shared_binds, body_binds:rhss_binds)
+ = sepBindsByDropPoint platform False to_drop
+ extra_fvs (body_fvs:rhss_fvs)
rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`
unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`
rule_fvs -- Don't forget the rule variables!
-- Push rhs_binds into the right hand side of the binding
- fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
+ fi_bind :: [RevFloatInBinds] -- One per "drop pt" conjured w/ fvs_of_rhss
-> [(Id, CoreExprWithFVs)]
-> [(Id, CoreExpr)]
@@ -556,7 +597,7 @@ fiBind platform to_drop (AnnRec bindings) body_fvs
| ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
------------------
-fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
+fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
fiRhs platform to_drop bndr rhs
| Just join_arity <- isJoinId_maybe bndr
, let (bndrs, body) = collectNAnnBndrs join_arity rhs
@@ -656,68 +697,84 @@ point.
We have to maintain the order on these drop-point-related lists.
-}
--- pprFIB :: FloatInBinds -> SDoc
+-- pprFIB :: RevFloatInBinds -> SDoc
-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]
sepBindsByDropPoint
:: Platform
- -> Bool -- True <=> is case expression
- -> [FreeVarSet] -- One set of FVs per drop point
- -- Always at least two long!
- -> FloatInBinds -- Candidate floaters
- -> [FloatInBinds] -- FIRST one is bindings which must not be floated
- -- inside any drop point; the rest correspond
- -- one-to-one with the input list of FV sets
+ -> Bool -- True <=> is case expression
+ -> RevFloatInBinds -- Candidate floaters
+ -> FreeVarSet -- here_fvs: if these vars are free in a binding,
+ -- don't float that binding inside any drop point
+ -> [FreeVarSet] -- fork_fvs: one set of FVs per drop point
+ -> ( RevFloatInBinds -- Bindings which must not be floated inside
+ , [RevFloatInBinds] ) -- Corresponds 1-1 with the input list of FV sets
-- Every input floater is returned somewhere in the result;
-- none are dropped, not even ones which don't seem to be
-- free in *any* of the drop-point fvs. Why? Because, for example,
-- a binding (let x = E in B) might have a specialised version of
-- x (say x') stored inside x, but x' isn't free in E or B.
+--
+-- The here_fvs argument is used for two things:
+-- * Avoid shadowing bugs: see Note [Shadowing and name capture]
+-- * Drop some of the bindings at the top, e.g. of an application
type DropBox = (FreeVarSet, FloatInBinds)
-sepBindsByDropPoint platform is_case drop_pts floaters
+dropBoxFloats :: DropBox -> RevFloatInBinds
+dropBoxFloats (_, floats) = reverse floats
+
+usedInDropBox :: DIdSet -> DropBox -> Bool
+usedInDropBox bndrs (db_fvs, _) = db_fvs `intersectsDVarSet` bndrs
+
+initDropBox :: DVarSet -> DropBox
+initDropBox fvs = (fvs, [])
+
+sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs
| null floaters -- Shortcut common case
- = [] : [[] | _ <- drop_pts]
+ = ([], [[] | _ <- fork_fvs])
| otherwise
- = assert (drop_pts `lengthAtLeast` 2) $
- go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
+ = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs)
where
- n_alts = length drop_pts
+ n_alts = length fork_fvs
- go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
- -- The *first* one in the argument list is the drop_here set
- -- The FloatInBinds in the lists are in the reverse of
- -- the normal FloatInBinds order; that is, they are the right way round!
+ go :: RevFloatInBinds -> DropBox -> [DropBox]
+ -> (RevFloatInBinds, [RevFloatInBinds])
+ -- The *first* one in the pair is the drop_here set
- go [] drop_boxes = map (reverse . snd) drop_boxes
+ go [] here_box fork_boxes
+ = (dropBoxFloats here_box, map dropBoxFloats fork_boxes)
- go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
- = go binds new_boxes
+ go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes
+ | drop_here = go binds (insert here_box) fork_boxes
+ | otherwise = go binds here_box new_fork_boxes
where
-- "here" means the group of bindings dropped at the top of the fork
- (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs
- | (fvs, _) <- drop_boxes]
+ used_here = bndrs `usedInDropBox` here_box
+ used_in_flags = case fork_boxes of
+ [] -> []
+ [_] -> [True] -- Push all bindings into a single branch
+ -- No need to look at its free vars
+ _ -> map (bndrs `usedInDropBox`) fork_boxes
+ -- Short-cut for the singleton case;
+ -- used for lambdas and singleton cases
drop_here = used_here || cant_push
n_used_alts = count id used_in_flags -- returns number of Trues in list.
cant_push
- | is_case = n_used_alts == n_alts -- Used in all, don't push
- -- Remember n_alts > 1
+ | is_case = (n_alts > 1 && n_used_alts == n_alts)
+ -- Used in all, muliple branches, don't push
|| (n_used_alts > 1 && not (floatIsDupable platform bind))
-- floatIsDupable: see Note [Duplicating floats]
| otherwise = floatIsCase bind || n_used_alts > 1
-- floatIsCase: see Note [Floating primops]
- new_boxes | drop_here = (insert here_box : fork_boxes)
- | otherwise = (here_box : new_fork_boxes)
-
new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
fork_boxes used_in_flags
@@ -727,8 +784,6 @@ sepBindsByDropPoint platform is_case drop_pts floaters
insert_maybe box True = insert box
insert_maybe box False = box
- go _ _ = panic "sepBindsByDropPoint/go"
-
{- Note [Duplicating floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -745,14 +800,14 @@ If the thing is used in all RHSs there is nothing gained,
so we don't duplicate then.
-}
-floatedBindsFVs :: FloatInBinds -> FreeVarSet
+floatedBindsFVs :: RevFloatInBinds -> FreeVarSet
floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
fbFVs :: FloatInBind -> DVarSet
fbFVs (FB _ fvs _) = fvs
-wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
--- Remember FloatInBinds is in *reverse* dependency order
+wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr
+-- Remember RevFloatInBinds is in *reverse* dependency order
wrapFloats [] e = e
wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Unit.Module.ModGuts
import GHC.Types.Literal ( litIsLifted )
import GHC.Types.Id
import GHC.Types.Id.Info ( IdDetails(..) )
+import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
@@ -1924,24 +1925,13 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
-- And build the results
; (qvars', pats') <- generaliseDictPats qvars pats
- ; let spec_body_ty = exprType spec_body
- (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)
- = calcSpecInfo fn call_pat extra_bndrs
- -- Annotate the variables with the strictness information from
- -- the function (see Note [Strictness information in worker binders])
- add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1
- (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)
- | add_void_arg
- -- See Note [SpecConstr needs to add void args first]
- , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []
- -- needsVoidWorkerArg: usual w/w hack to avoid generating
- -- a spec_rhs of unlifted type and no args.
- , !spec_arity <- spec_arity1 + 1
- , !spec_join_arity <- fmap (+ 1) spec_join_arity1
- = (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)
- | otherwise
- = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1)
+ ; let spec_body_ty = exprType spec_body
+ (spec_lam_args, spec_call_args, spec_sig)
+ = calcSpecInfo fn arg_bndrs call_pat extra_bndrs
+ spec_arity = count isId spec_lam_args
+ spec_join_arity | isJoinId fn = Just (length spec_call_args)
+ | otherwise = Nothing
spec_id = asWorkerLikeId $
mkLocalId spec_name ManyTy
(mkLamTypes spec_lam_args spec_body_ty)
@@ -1953,11 +1943,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
-- Conditionally use result of new worker-wrapper transform
spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)
- rule_rhs = mkVarApps (Var spec_id) $
- -- This will give us all the arguments we quantify over
- -- in the rule plus the void argument if present
- -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`
- dropTail (length extra_bndrs) spec_call_args
+ rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
this_mod = sc_module $ sc_opts env
rule = mkRule this_mod True {- Auto -} True {- Local -}
@@ -2020,33 +2006,55 @@ mkSeqs seqees res_ty rhs =
= rhs
-{- Note [SpecConstr needs to add void args first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [SpecConstr void argument insertion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a function
+ f :: Bool -> forall t. blah
f start @t = e
We want to specialize for a partially applied call `f True`.
See also Note [SpecConstr call patterns], second Wrinkle.
Naively we would expect to get
+ $sf :: forall t. blah
$sf @t = $se
RULE: f True = $sf
-The specialized function only takes a single type argument
-so we add a void argument to prevent it from turning into
-a thunk. See Note [Protecting the last value argument] for details
-why. Normally we would add the void argument after the
-type argument giving us:
+The specialized function only takes a single type argument so we add a
+void argument to prevent it from turning into a thunk. See Note
+[Protecting the last value argument] for details why. Normally we
+would add the void argument after the type argument giving us:
+
$sf :: forall t. Void# -> bla
$sf @t void = $se
RULE: f True = $sf void# (wrong)
-But if you look closely this wouldn't typecheck!
-If we substitute `f True` with `$sf void#` we expect the type argument to be applied first
-but we apply void# first.
-The easiest fix seems to be just to add the void argument to the front of the arguments.
-Now we get:
+
+But if you look closely this wouldn't typecheck! If we substitute `f
+True` with `$sf void#` we expect the type argument to be applied first
+but we apply void# first. The easiest fix seems to be just to add the
+void argument to the front of the arguments. Now we get:
+
$sf :: Void# -> forall t. bla
$sf void @t = $se
RULE: f True = $sf void#
+
And now we can substitute `f True` with `$sf void#` with everything working out nicely!
+More precisely, in `calcSpecInfo`
+(i) we need the void arg to /precede/ the `extra_bndrs`, but
+(ii) it must still /follow/ `qvar_bndrs`.
+
+Example to illustrate (ii):
+ f :: forall r (a :: TYPE r). Bool -> a
+ f = /\r. /\(a::TYPE r). \b. body
+
+ {- Specialise for f _ _ True -}
+
+ $sf :: forall r (a :: TYPE r). Void# -> a
+ $sf = /\r. /\(a::TYPE r). \v. body[True/b]
+ RULE: forall r (a :: TYPE r). f @r @a True = $sf @r @a void#
+
+The void argument must follow the foralls, lest the forall be
+ill-kinded. See Note [Worker/wrapper needs to add void arg last] in
+GHC.Core.Opt.WorkWrap.Utils.
+
Note [generaliseDictPats]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these two rules (#21831, item 2):
@@ -2075,36 +2083,45 @@ And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new
"SC:foo" to match the (prefix of) "SPEC:foo".
-}
-calcSpecInfo :: Id -- The original function
- -> CallPat -- Call pattern
- -> [Var] -- Extra bndrs
- -> ( [Var] -- Demand-decorated binders
- , DmdSig -- Strictness of specialised thing
- , Arity, Maybe JoinArity ) -- Arities of specialised thing
+calcSpecInfo :: Id -- The original function
+ -> [InVar] -- Lambda binders of original RHS
+ -> CallPat -- Call pattern
+ -> [Var] -- Extra bndrs
+ -> ( [Var] -- Demand-decorated lambda binders
+ -- for RHS of specialised function
+ , [Var] -- Args for call site
+ , DmdSig ) -- Strictness of specialised thing
-- Calculate bits of IdInfo for the specialised function
-- See Note [Transfer strictness]
-- See Note [Strictness information in worker binders]
-calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
- | isJoinId fn -- Join points have strictness and arity for LHS only
- = ( bndrs_w_dmds
- , mkClosedDmdSig qvar_dmds div
- , count isId qvars
- , Just (length qvars) )
- | otherwise
- = ( bndrs_w_dmds
- , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div
- , count isId qvars + count isId extra_bndrs
- , Nothing )
+calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
+ = ( spec_lam_bndrs_w_dmds
+ , spec_call_args
+ , mkClosedDmdSig [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] div )
where
DmdSig (DmdType _ fn_dmds div) = idDmdSig fn
- val_pats = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop
- -- from the original functions demand and for setting up dmd_env.
+ val_pats = filterOut isTypeArg pats
+ -- Value args at call sites, used to determine how many demands to drop
+ -- from the original functions demand and for setting up dmd_env.
+ dmd_env = go emptyVarEnv fn_dmds val_pats
qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
extra_dmds = dropList val_pats fn_dmds
- bndrs_w_dmds = set_dmds qvars qvar_dmds
- ++ set_dmds extra_bndrs extra_dmds
+ -- Annotate the variables with the strictness information from
+ -- the function (see Note [Strictness information in worker binders])
+ qvars_w_dmds = set_dmds qvars qvar_dmds
+ extras_w_dmds = set_dmds extra_bndrs extra_dmds
+ spec_lam_bndrs_w_dmds = final_qvars_w_dmds ++ extras_w_dmds
+
+ (final_qvars_w_dmds, spec_call_args)
+ | needsVoidWorkerArg fn arg_bndrs (qvars ++ extra_bndrs)
+ -- Usual w/w hack to avoid generating
+ -- a spec_rhs of unlifted or ill-kinded type and no args.
+ -- See Note [SpecConstr void argument insertion]
+ = ( qvars_w_dmds ++ [voidArgId], qvars ++ [voidPrimId] )
+ | otherwise
+ = ( qvars_w_dmds, qvars )
set_dmds :: [Var] -> [Demand] -> [Var]
set_dmds [] _ = []
@@ -2112,8 +2129,6 @@ calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
set_dmds (v:vs) ds@(d:ds') | isTyVar v = v : set_dmds vs ds
| otherwise = setIdDemandInfo v d : set_dmds vs ds'
- dmd_env = go emptyVarEnv fn_dmds val_pats
-
go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
-- We've filtered out all the type patterns already
go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
@@ -2127,7 +2142,6 @@ calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
= go env ds args
go_one env _ _ = env
-
{-
Note [spec_usg includes rhs_usg]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -9,7 +9,7 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser
module GHC.Core.Opt.WorkWrap.Utils
( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one
- , needsVoidWorkerArg, addVoidWorkerArg
+ , needsVoidWorkerArg
, DataConPatContext(..)
, UnboxingDecision(..), canUnboxArg
, findTypeShape, IsRecDataConResult(..), isRecDataCon
@@ -377,25 +377,34 @@ We use the state-token type which generates no code.
-- Note [Preserving float barriers].
needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool
needsVoidWorkerArg fn_id wrap_args work_args
- = not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]
- || needs_float_barrier -- See Note [Preserving float barriers]
+ = thunk_problem -- See Note [Protecting the last value argument]
+ || needs_float_barrier -- See Note [Preserving float barriers]
where
- no_value_arg = all (not . isId) work_args
+ -- thunk_problem: see Note [Protecting the last value argument]
+ -- For join points we are only worried about (4), not (1-4).
+ -- And (4) can't happen if (null work_args)
+ -- (We could be more clever, by looking at the result type, but
+ -- this approach is simple and conservative.)
+ thunk_problem | isJoinId fn_id = no_value_arg && not (null work_args)
+ | otherwise = no_value_arg
+ no_value_arg = not (any isId work_args)
+
+ -- needs_float_barrier: see Note [Preserving float barriers]
+ needs_float_barrier = wrap_had_barrier && not work_has_barrier
is_float_barrier v = isId v && hasNoOneShotInfo (idOneShotInfo v)
wrap_had_barrier = any is_float_barrier wrap_args
work_has_barrier = any is_float_barrier work_args
- needs_float_barrier = wrap_had_barrier && not work_has_barrier
--- | Inserts a `Void#` arg before the first argument.
---
--- Why as the first argument? See Note [SpecConstr needs to add void args first]
--- in SpecConstr.
+-- | Inserts a `Void#` arg as the last argument.
+-- Why last? See Note [Worker/wrapper needs to add void arg last]
addVoidWorkerArg :: [Var] -> [StrictnessMark]
- -> ([Var], -- Lambda bound args
- [Var], -- Args at call site
- [StrictnessMark]) -- str semantics for the worker args.
+ -> ( [Var] -- Lambda bound args
+ , [Var] -- Args at call site
+ , [StrictnessMark]) -- str semantics for the worker args
addVoidWorkerArg work_args str_marks
- = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:str_marks)
+ = ( work_args ++ [voidArgId]
+ , work_args ++ [voidPrimId]
+ , str_marks ++ [NotMarkedStrict] )
{-
Note [Protecting the last value argument]
@@ -403,8 +412,8 @@ Note [Protecting the last value argument]
If the user writes (\_ -> E), they might be intentionally disallowing
the sharing of E. Since absence analysis and worker-wrapper are keen
to remove such unused arguments, we add in a void argument to prevent
-the function from becoming a thunk. Three reasons why turning a function
-into a thunk might be bad:
+the function from becoming a thunk. Here are several reasons why turning
+a function into a thunk might be bad:
1) It can create a space leak. e.g.
f x = let y () = [1..x]
@@ -423,7 +432,19 @@ into a thunk might be bad:
g = \x. 30#
Removing the \x would leave an unlifted binding.
-NB: none of these apply to a join point.
+4) It can create a worker of ill-kinded type (#22275). Consider
+ f :: forall r (a :: TYPE r). () -> a
+ f x = f x
+ Here `x` is absent, but if we simply drop it we'd end up with
+ $wf :: forall r (a :: TYPE r). a
+ But alas $wf's type is ill-kinded: the kind of (/\r (a::TYPE r).a)
+ is (TYPE r), which mentions the bound variable `r`. See also
+ Note [Worker/wrapper needs to add void arg last]
+
+See also Note [Preserving float barriers]
+
+NB: Of these, only (1-3) don't apply to a join point, which can be
+unlifted even if the RHS is not ok-for-speculation.
Note [Preserving float barriers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -457,7 +478,7 @@ which some are absent or one-shot and the resulting worker arguments:
* \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...
Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#
- * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...
+p * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...
Worker arg `c` is a float barrier.
* \a.\b{Abs}.\c{os}... ==> \a.\c{os}...
Worker arg `a` is a float barrier.
@@ -469,6 +490,27 @@ which some are absent or one-shot and the resulting worker arguments:
Executable examples in T21150.
+Note [Worker/wrapper needs to add void arg last]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider point (4) of Note [Protecting the last value argument]
+
+ f :: forall r (a :: TYPE r). () -> a
+ f x = f x
+
+As pointed out in (4) we need to add a void argument. But if we add
+it /first/ we'd get
+
+ $wf :: Void# -> forall r (a :: TYPE r). a
+ $wf = ...
+
+But alas $wf's type is /still/ still-kinded, just as before in (4).
+Solution is simple: put the void argument /last/:
+
+ $wf :: forall r (a :: TYPE r). Void# -> a
+ $wf = ...
+
+c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr
+
Note [Join points and beta-redexes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Originally, the worker would invoke the original function by calling it with
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -50,7 +50,7 @@ module GHC.Core.Type (
mkSpecForAllTy, mkSpecForAllTys,
mkVisForAllTys, mkTyCoInvForAllTy,
mkInfForAllTy, mkInfForAllTys,
- splitForAllTyCoVars,
+ splitForAllTyCoVars, splitForAllTyVars,
splitForAllReqTyBinders, splitForAllInvisTyBinders,
splitForAllForAllTyBinders,
splitForAllTyCoVar_maybe, splitForAllTyCoVar,
@@ -1337,7 +1337,7 @@ ty_con_app_fun_maybe many_ty_co tc args
| otherwise
= Nothing
-mkFunctionType :: Mult -> Type -> Type -> Type
+mkFunctionType :: HasDebugCallStack => Mult -> Type -> Type -> Type
-- ^ This one works out the FunTyFlag from the argument type
-- See GHC.Types.Var Note [FunTyFlag]
mkFunctionType mult arg_ty res_ty
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -159,7 +159,7 @@ coreAltsType :: [CoreAlt] -> Type
coreAltsType (alt:_) = coreAltType alt
coreAltsType [] = panic "coreAltsType"
-mkLamType :: Var -> Type -> Type
+mkLamType :: HasDebugCallStack => Var -> Type -> Type
-- ^ Makes a @(->)@ type or an implicit forall type, depending
-- on whether it is given a type variable or a term variable.
-- This is used, for example, when producing the type of a lambda.
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -49,7 +49,7 @@ import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
import GHC.Tc.Utils.TcType
-import GHC.Tc.Validity (checkValidType)
+import GHC.Tc.Validity (checkValidType, checkEscapingKind)
import GHC.Core.Predicate
import GHC.Core.Reduction ( Reduction(..) )
@@ -906,7 +906,8 @@ mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mo
, ppr inferred_poly_ty])
; unless insoluble $
addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
- checkValidType (InfSigCtxt poly_name) inferred_poly_ty
+ do { checkEscapingKind inferred_poly_ty
+ ; checkValidType (InfSigCtxt poly_name) inferred_poly_ty }
-- See Note [Validity of inferred types]
-- If we found an insoluble error in the function definition, don't
-- do this check; otherwise (#14000) we may report an ambiguity
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -4409,10 +4409,7 @@ checkValidDataCon dflags existential_ok tc con
-- e.g. reject this: MkT :: T (forall a. a->a)
-- Reason: it's really the argument of an equality constraint
; checkValidMonoType orig_res_ty
-
- -- Check for an escaping result kind
- -- See Note [Check for escaping result kind]
- ; checkEscapingKind con
+ ; checkEscapingKind (dataConWrapperType con)
-- For /data/ types check that each argument has a fixed runtime rep
-- If we are dealing with a /newtype/, we allow representation
@@ -4577,47 +4574,6 @@ checkNewDataCon con
ok_mult OneTy = True
ok_mult _ = False
-
--- | Reject nullary data constructors where a type variable
--- would escape through the result kind
--- See Note [Check for escaping result kind]
-checkEscapingKind :: DataCon -> TcM ()
-checkEscapingKind data_con
- | null eq_spec, null theta, null arg_tys
- , let tau_kind = typeKind res_ty
- , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind
- -- Ensure that none of the tvs occur in the kind of the forall
- -- /after/ expanding type synonyms.
- -- See Note [Phantom type variables in kinds] in GHC.Core.Type
- = failWithTc $ TcRnForAllEscapeError (dataConWrapperType data_con) tau_kind
- | otherwise
- = return ()
- where
- (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
- = dataConFullSig data_con
-
-{- Note [Check for escaping result kind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider:
- type T :: TYPE (BoxedRep l)
- data T = MkT
-This is not OK: we get
- MkT :: forall l. T @l :: TYPE (BoxedRep l)
-which is ill-kinded.
-
-For ordinary type signatures f :: blah, we make this check as part of kind-checking
-the type signature; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.
-But for data constructors we check the type piecemeal, and there is no very
-convenient place to do it. For example, note that it only applies for /nullary/
-constructors. If we had
- data T = MkT Int
-then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.
-
-So we make the check in checkValidDataCon.
-
-Historical note: we used to do the check in checkValidType (#20929 discusses).
--}
-
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Tc.Validity (
Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType,
checkValidTheta,
checkValidInstance, checkValidInstHead, validDerivPred,
- checkTySynRhs,
+ checkTySynRhs, checkEscapingKind,
checkValidCoAxiom, checkValidCoAxBranch,
checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,
arityErr,
@@ -462,6 +462,53 @@ checkTySynRhs ctxt ty
where
actual_kind = typeKind ty
+{- Note [Check for escaping result kind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+ type T :: TYPE (BoxedRep l)
+ data T = MkT
+This is not OK: we get
+ MkT :: forall l. T @l :: TYPE (BoxedRep l)
+which is ill-kinded.
+
+For ordinary /user-written type signatures f :: blah, we make this
+check as part of kind-checking the type signature in tcHsSigType; see
+Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.
+
+But in two other places we need to check for an escaping result kind:
+
+* For data constructors we check the type piecemeal, and there is no
+ very convenient place to do it. For example, note that it only
+ applies for /nullary/ constructors. If we had
+ data T = MkT Int
+ then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.
+
+ So we make the check in checkValidDataCon.
+
+* When inferring the type of a function, there is no user-written type
+ that we are checking. Forgetting this led to #22743. Now we call
+ checkEscapingKind in GHC.Tc.Gen.Bind.mkInferredPolyId
+
+Historical note: we used to do the escaping-kind check in
+checkValidType (#20929 discusses), but that is now redundant.
+-}
+
+checkEscapingKind :: Type -> TcM ()
+-- Give a sigma-type (forall a1 .. an. ty), where (ty :: ki),
+-- check that `ki` does not mention any of the binders a1..an.
+-- Otherwise the type is ill-kinded
+-- See Note [Check for escaping result kind]
+checkEscapingKind poly_ty
+ | (tvs, tau) <- splitForAllTyVars poly_ty
+ , let tau_kind = typeKind tau
+ , Nothing <- occCheckExpand tvs tau_kind
+ -- Ensure that none of the tvs occur in the kind of the forall
+ -- /after/ expanding type synonyms.
+ -- See Note [Phantom type variables in kinds] in GHC.Core.Type
+ = failWithTc $ TcRnForAllEscapeError poly_ty tau_kind
+ | otherwise
+ = return ()
+
funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result
funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
funArgResRank other_rank = (other_rank, other_rank)
@@ -757,6 +804,9 @@ check_type ve@(ValidityEnv{ ve_tidy_env = env
; check_type (ve{ve_tidy_env = env'}) tau
-- Allow foralls to right of arrow
+ -- Note: skolem-escape in types (e.g. forall r (a::r). a) is handled
+ -- by tcHsSigType and the constraint solver, so no need to
+ -- check it here; c.f. #20929
}
where
(tvbs, phi) = tcSplitForAllTyVarBinders ty
=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -126,6 +126,9 @@ Runtime system
Previously only live blocks were taken into account.
This makes it more likely to trigger promptly when the heap is highly fragmented.
+- Fixed a bug that sometimes caused live sparks to be GC'ed too early either during
+ minor GC or major GC with workstealing disabled. See #22528.
+
``base`` library
~~~~~~~~~~~~~~~~
@@ -146,9 +149,9 @@ Runtime system
- Updated to `Unicode 15.0.0 <https://www.unicode.org/versions/Unicode15.0.0/>`_.
-- Add standard Unicode case predicates :base-ref:`Data.Char.isUpperCase` and
- :base-ref:`Data.Char.isLowerCase`. These predicates use the standard Unicode
- case properties and are more intuitive than :base-ref:`Data.Char.isUpper` and
+- Add standard Unicode case predicates :base-ref:`Data.Char.isUpperCase` and
+ :base-ref:`Data.Char.isLowerCase`. These predicates use the standard Unicode
+ case properties and are more intuitive than :base-ref:`Data.Char.isUpper` and
:base-ref:`Data.Char.isLower`.
``ghc-prim`` library
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit 1543e054a314865d89a259065921d5acba03d966
+Subproject commit 9cab76dc861f651c3940e873ce921d9e09733cc8
=====================================
libraries/parsec
=====================================
@@ -1 +1 @@
-Subproject commit 0e23b3246fd7f6d125129316dcbedd609e6d2dca
+Subproject commit 1f542120d9adc5e22f8791a6d595210e93c6c389
=====================================
m4/fp_settings.m4
=====================================
@@ -10,12 +10,12 @@ AC_DEFUN([FP_SETTINGS],
# See Note [tooldir: How GHC finds mingw on Windows]
mingw_bin_prefix='$$tooldir/mingw/bin/'
SettingsCCompilerCommand="${mingw_bin_prefix}clang.exe"
- SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 -I$$tooldir/mingw/include"
+ SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 -I\$\$tooldir/mingw/include"
SettingsCxxCompilerCommand="${mingw_bin_prefix}clang++.exe"
- SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2 -I$$tooldir/mingw/include"
- SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2 -L$$tooldir/mingw/lib -L$$tooldir/mingw/x86_64-w64-mingw32/lib"
+ SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2 -I\$\$tooldir/mingw/include"
+ SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2 -L\$\$tooldir/mingw/lib -L\$\$tooldir/mingw/x86_64-w64-mingw32/lib"
SettingsHaskellCPPCommand="${mingw_bin_prefix}clang.exe"
- SettingsHaskellCPPFlags="$HaskellCPPArgs -I$$tooldir/mingw/include"
+ SettingsHaskellCPPFlags="$HaskellCPPArgs -I\$\$tooldir/mingw/include"
SettingsLdCommand="${mingw_bin_prefix}ld.lld.exe"
SettingsLdFlags=""
# LLD does not support object merging (#21068)
=====================================
rts/Sparks.c
=====================================
@@ -79,6 +79,34 @@ newSpark (StgRegTable *reg, StgClosure *p)
return 1;
}
+/* Note [Pruning the spark pool]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+pruneSparkQueue checks if closures have been evacuated to know weither or
+not a spark can be GCed. If it was evacuated it's live and we keep the spark
+alive. If it hasn't been evacuated at the end of GC we can assume it's dead and
+remove the spark from the pool.
+
+To make this sound we must ensure GC has finished evacuating live objects before
+we prune the spark pool. Otherwise we might GC a spark before it has been evaluated.
+
+* If we run sequential GC then the GC Lead simply prunes after
+everything has been evacuated.
+
+* If we run parallel gc without work stealing then GC workers are not synchronized
+at any point before the worker returns. So we leave it to the GC Lead to prune
+sparks once evacuation has been finished and all workers returned.
+
+* If work stealing is enabled all GC threads will be running
+scavenge_until_all_done until regular heap marking is done. After which
+all workers will converge on a synchronization point. This means
+we can perform spark pruning inside the GC workers at this point.
+The only wart is that if we prune sparks locally we might
+miss sparks reachable via weak pointers as these are marked in the main
+thread concurrently to the calls to pruneSparkQueue. To fix this problem would
+require a GC barrier but that seems to high a price to pay.
+*/
+
+
/* --------------------------------------------------------------------------
* Remove all sparks from the spark queues which should not spark any
* more. Called after GC. We assume exclusive access to the structure
@@ -181,7 +209,7 @@ pruneSparkQueue (bool nonmovingMarkFinished, Capability *cap)
cap->spark_stats.fizzled++;
traceEventSparkFizzle(cap);
} else {
- info = spark->header.info;
+ info = RELAXED_LOAD(&spark->header.info);
load_load_barrier();
if (IS_FORWARDING_PTR(info)) {
tmp = (StgClosure*)UN_FORWARDING_PTR(info);
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -759,10 +759,8 @@ void postCapsetVecEvent (EventTypeNum tag,
// 1 + strlen to account for the trailing \0, used as separator
int increment = 1 + strlen(argv[i]);
if (size + increment > EVENT_PAYLOAD_SIZE_MAX) {
- errorBelch("Event size exceeds EVENT_PAYLOAD_SIZE_MAX, record only %"
- FMT_Int " out of %" FMT_Int " args",
- (long long) i,
- (long long) argc);
+ errorBelch("Event size exceeds EVENT_PAYLOAD_SIZE_MAX, record only "
+ "%d out of %d args", i, argc);
argc = i;
break;
} else {
=====================================
rts/sm/GC.c
=====================================
@@ -292,6 +292,7 @@ GarbageCollect (uint32_t collect_gen,
any_work, scav_find_work, max_n_todo_overflow;
#if defined(THREADED_RTS)
gc_thread *saved_gct;
+ bool gc_sparks_all_caps;
#endif
uint32_t g, n;
// The time we should report our heap census as occurring at, if necessary.
@@ -559,6 +560,9 @@ GarbageCollect (uint32_t collect_gen,
StgTSO *resurrected_threads = END_TSO_QUEUE;
// must be last... invariant is that everything is fully
// scavenged at this point.
+#if defined(THREADED_RTS)
+ gc_sparks_all_caps = !work_stealing || !is_par_gc();
+#endif
work_stealing = false;
while (traverseWeakPtrList(&dead_weak_ptr_list, &resurrected_threads))
{
@@ -571,8 +575,9 @@ GarbageCollect (uint32_t collect_gen,
gcStableNameTable();
#if defined(THREADED_RTS)
- if (!is_par_gc()) {
- for (n = 0; n < getNumCapabilities(); n++) {
+ // See Note [Pruning the spark pool]
+ if(gc_sparks_all_caps) {
+ for (n = 0; n < n_capabilities; n++) {
pruneSparkQueue(false, getCapability(n));
}
} else {
@@ -1379,7 +1384,6 @@ void
gcWorkerThread (Capability *cap)
{
gc_thread *saved_gct;
-
// necessary if we stole a callee-saves register for gct:
saved_gct = gct;
@@ -1410,13 +1414,10 @@ gcWorkerThread (Capability *cap)
scavenge_until_all_done();
#if defined(THREADED_RTS)
- // Now that the whole heap is marked, we discard any sparks that
- // were found to be unreachable. The main GC thread is currently
- // marking heap reachable via weak pointers, so it is
- // non-deterministic whether a spark will be retained if it is
- // only reachable via weak pointers. To fix this problem would
- // require another GC barrier, which is too high a price.
- pruneSparkQueue(false, cap);
+ // See Note [Pruning the spark pool]
+ if(work_stealing && is_par_gc()) {
+ pruneSparkQueue(false, cap);
+ }
#endif
// Wait until we're told to continue
=====================================
rts/sm/Storage.c
=====================================
@@ -1404,7 +1404,7 @@ allocatePinned (Capability *cap, W_ n /*words*/, W_ alignment /*bytes*/, W_ alig
void
dirty_MUT_VAR(StgRegTable *reg, StgMutVar *mvar, StgClosure *old)
{
-#if defined(THREADED_RTS)
+#if !defined(THREADED_RTS)
// This doesn't hold in the threaded RTS as we may race with another thread.
ASSERT(RELAXED_LOAD(&mvar->header.info) == &stg_MUT_VAR_CLEAN_info);
#endif
=====================================
testsuite/tests/ghci/scripts/T9881.stdout
=====================================
@@ -19,19 +19,19 @@ instance Ord Data.ByteString.Lazy.ByteString
type Data.ByteString.ByteString :: *
data Data.ByteString.ByteString
- = Data.ByteString.Internal.BS {-# UNPACK #-}(GHC.ForeignPtr.ForeignPtr
- GHC.Word.Word8)
- {-# UNPACK #-}Int
- -- Defined in ‘Data.ByteString.Internal’
+ = bytestring-0.11.4.0:Data.ByteString.Internal.Type.BS {-# UNPACK #-}(GHC.ForeignPtr.ForeignPtr
+ GHC.Word.Word8)
+ {-# UNPACK #-}Int
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Monoid Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Read Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Semigroup Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Show Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Eq Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Ord Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
=====================================
testsuite/tests/ghci/scripts/ghci025.stdout
=====================================
@@ -53,7 +53,9 @@ Prelude.length :: Data.Foldable.Foldable t => t a -> GHC.Types.Int
-- imported via T
type T.Integer :: *
data T.Integer = ...
-T.length :: Data.ByteString.Internal.ByteString -> GHC.Types.Int
+T.length ::
+ bytestring-0.11.4.0:Data.ByteString.Internal.Type.ByteString
+ -> GHC.Types.Int
:browse! T
-- defined locally
T.length :: T.Integer
=====================================
testsuite/tests/polykinds/T22743.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE DataKinds #-}
+module M where
+
+import GHC.Exts
+import Data.Kind
+
+f :: forall f (g :: Type) (a :: TYPE (f g)). Int -> a
+f = f
+
+x = f 0
=====================================
testsuite/tests/polykinds/T22743.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T22743.hs:10:1: error: [GHC-31147]
+ • Quantified type's kind mentions quantified type variable
+ type: ‘forall {f :: * -> RuntimeRep} {g} {a :: TYPE (f g)}. a’
+ where the body of the forall has this kind: ‘TYPE (f g)’
+ • When checking the inferred type
+ x :: forall {f :: * -> RuntimeRep} {g} {a :: TYPE (f g)}. a
=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -241,3 +241,4 @@ test('T19739c', normal, compile, [''])
test('T19739d', normal, compile, [''])
test('T22379a', normal, compile, [''])
test('T22379b', normal, compile, [''])
+test('T22743', normal, compile_fail, [''])
=====================================
testsuite/tests/simplCore/should_compile/T13143.stderr
=====================================
@@ -1,14 +1,14 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 71, types: 41, coercions: 0, joins: 0/0}
+ = {terms: 71, types: 40, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker]
- :: (# #) -> forall {a}. a
+ :: forall {a}. (# #) -> a
[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []]
-T13143.$wf = \ _ [Occ=Dead] (@a) -> T13143.$wf GHC.Prim.(##) @a
+T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)
end Rec }
-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
@@ -17,55 +17,60 @@ f [InlPrag=NOINLINE[final]] :: forall a. Int -> a
Arity=1,
Str=<B>b,
Cpr=b,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
- Tmpl= \ (@a) _ [Occ=Dead] -> T13143.$wf GHC.Prim.(##) @a}]
-f = \ (@a) _ [Occ=Dead] -> T13143.$wf GHC.Prim.(##) @a
+ Tmpl= \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)}]
+f = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T13143.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T13143.$trModule3 = GHC.Types.TrNameS T13143.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T13143.$trModule2 = "T13143"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T13143.$trModule1 = GHC.Types.TrNameS T13143.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T13143.$trModule
= GHC.Types.Module T13143.$trModule3 T13143.$trModule1
--- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-lvl :: forall {a}. a
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+lvl :: Int
[GblId, Str=b, Cpr=b]
-lvl = T13143.$wf GHC.Prim.(##)
+lvl = T13143.$wf @Int GHC.Prim.(##)
Rec {
--- RHS size: {terms: 28, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 28, types: 7, coercions: 0, joins: 0/0}
T13143.$wg [InlPrag=[2], Occ=LoopBreaker]
:: Bool -> Bool -> GHC.Prim.Int# -> GHC.Prim.Int#
[GblId[StrictWorker([!, !])],
@@ -94,8 +99,8 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int
Arity=3,
Str=<1L><1L><1!P(L)>,
Cpr=1,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
Tmpl= \ (ds [Occ=Once1] :: Bool)
(ds1 [Occ=Once1] :: Bool)
=====================================
testsuite/tests/simplCore/should_compile/T18328.stderr
=====================================
@@ -1,84 +1,90 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 65, types: 53, coercions: 0, joins: 1/1}
+ = {terms: 69, types: 55, coercions: 0, joins: 1/1}
--- RHS size: {terms: 38, types: 23, coercions: 0, joins: 1/1}
+-- RHS size: {terms: 42, types: 25, coercions: 0, joins: 1/1}
T18328.$wf [InlPrag=[2]]
:: forall {a}. GHC.Prim.Int# -> [a] -> [a] -> [a]
-[GblId,
+[GblId[StrictWorker([~, !])],
Arity=3,
Str=<SL><SL><ML>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [176 0 0] 306 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [176 0 0] 306 0}]
T18328.$wf
- = \ (@a) (ww :: GHC.Prim.Int#) (w :: [a]) (w1 :: [a]) ->
+ = \ (@a) (ww :: GHC.Prim.Int#) (ys :: [a]) (eta :: [a]) ->
join {
- $wj [InlPrag=NOINLINE, Dmd=ML] :: forall {p}. [a]
- [LclId[JoinId(1)]]
- $wj (@p)
+ $wj [InlPrag=NOINLINE, Dmd=MC(1,L)] :: forall {p}. (# #) -> [a]
+ [LclId[JoinId(2)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
+ $wj (@p) _ [Occ=Dead, OS=OneShot]
= case ww of {
- __DEFAULT -> ++ @a w (++ @a w (++ @a w w1));
- 3# -> ++ @a w (++ @a w (++ @a w (++ @a w w1)))
+ __DEFAULT -> ++ @a ys (++ @a ys (++ @a ys eta));
+ 3# -> ++ @a ys (++ @a ys (++ @a ys (++ @a ys eta)))
} } in
case ww of {
- __DEFAULT -> ++ @a w w1;
- 1# -> jump $wj @Integer;
- 2# -> jump $wj @Integer;
- 3# -> jump $wj @Integer
+ __DEFAULT -> ++ @a ys eta;
+ 1# -> jump $wj @Integer GHC.Prim.(##);
+ 2# -> jump $wj @Integer GHC.Prim.(##);
+ 3# -> jump $wj @Integer GHC.Prim.(##)
}
-- RHS size: {terms: 11, types: 9, coercions: 0, joins: 0/0}
f [InlPrag=[2]] :: forall a. Int -> [a] -> [a] -> [a]
[GblId,
Arity=3,
- Str=<1P(SL)><SL><ML>,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Str=<1!P(SL)><SL><ML>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
Tmpl= \ (@a)
- (w [Occ=Once1!] :: Int)
- (w1 [Occ=Once1] :: [a])
- (w2 [Occ=Once1] :: [a]) ->
- case w of { GHC.Types.I# ww [Occ=Once1] ->
- T18328.$wf @a ww w1 w2
+ (x [Occ=Once1!] :: Int)
+ (ys [Occ=Once1] :: [a])
+ (eta [Occ=Once1] :: [a]) ->
+ case x of { GHC.Types.I# ww [Occ=Once1] ->
+ T18328.$wf @a ww ys eta
}}]
-f = \ (@a) (w :: Int) (w1 :: [a]) (w2 :: [a]) ->
- case w of { GHC.Types.I# ww -> T18328.$wf @a ww w1 w2 }
+f = \ (@a) (x :: Int) (ys :: [a]) (eta :: [a]) ->
+ case x of { GHC.Types.I# ww -> T18328.$wf @a ww ys eta }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T18328.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18328.$trModule3 = GHC.Types.TrNameS T18328.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T18328.$trModule2 = "T18328"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18328.$trModule1 = GHC.Types.TrNameS T18328.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18328.$trModule
= GHC.Types.Module T18328.$trModule3 T18328.$trModule1
=====================================
testsuite/tests/simplCore/should_compile/T22662.hs
=====================================
@@ -0,0 +1,6 @@
+module T22662 where
+
+import Data.Set
+
+foo x = sequence_ [ f y | y <- x ]
+ where f _ = return (fromList [0])
=====================================
testsuite/tests/simplCore/should_compile/T22725.hs
=====================================
@@ -0,0 +1,6 @@
+module M where
+
+import GHC.Exts (TYPE)
+
+f :: forall r (a :: TYPE r). () -> a
+f x = f x
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -461,3 +461,5 @@ test('T21476', normal, compile, [''])
test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings -fno-omit-interface-pragmas -fno-ignore-interface-pragmas'])
test('T22459', normal, compile, [''])
test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
+test('T22725', normal, compile, ['-O'])
+test('T22662', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed5aaafdbc649df6bce18c51827a2576d7948f35...991b9ca567389114e8bfd7bd9c5483a1602b2427
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed5aaafdbc649df6bce18c51827a2576d7948f35...991b9ca567389114e8bfd7bd9c5483a1602b2427
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/20230118/84c6e935/attachment-0001.html>
More information about the ghc-commits
mailing list