[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: ci: Upgrade darwin, windows and freebsd CI to use GHC-9.4.3
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Jan 7 14:44:47 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c306d939 by Matthew Pickering at 2023-01-06T22:08:53-05:00
ci: Upgrade darwin, windows and freebsd CI to use GHC-9.4.3
Fixes #22599
- - - - -
0db496ff by Matthew Pickering at 2023-01-06T22:08:53-05:00
darwin ci: Explicitly pass desired build triple to configure
On the zw3rk machines for some reason the build machine was inferred to
be arm64. Setting the build triple appropiately resolve this confusion
and we produce x86 binaries.
- - - - -
2459c358 by Ben Gamari at 2023-01-06T22:09:29-05:00
rts: MUT_VAR is not a StgMutArrPtrs
There was previously a comment claiming that the MUT_VAR closure type
had the layout of StgMutArrPtrs.
- - - - -
ed149ef4 by Simon Peyton Jones at 2023-01-07T09:44:35-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
- - - - -
7d997a06 by Matthew Pickering at 2023-01-07T09:44:35-05:00
T10955: Set DYLD_LIBRARY_PATH for darwin
The correct path to direct the dynamic linker on darwin is
DYLD_LIBRARY_PATH rather than LD_LIBRARY_PATH. On recent versions of OSX
using LD_LIBRARY_PATH seems to have stopped working.
For more reading see:
https://stackoverflow.com/questions/3146274/is-it-ok-to-use-dyld-library-path-on-mac-os-x-and-whats-the-dynamic-library-s
- - - - -
1a6174d4 by Matthew Pickering at 2023-01-07T09:44:35-05:00
Skip T18623 on darwin (to add to the long list of OSs)
On recent versions of OSX, running `ulimit -v` results in
```
ulimit: setrlimit failed: invalid argument
```
Time is too short to work out what random stuff Apple has been doing
with ulimit, so just skip the test like we do for other platforms.
- - - - -
857c2404 by Matthew Pickering at 2023-01-07T09:44:35-05:00
Pass -Wl,-no_fixup_chains to ld64 when appropiate
Recent versions of MacOS use a version of ld where `-fixup_chains` is on by default.
This is incompatible with our usage of `-undefined dynamic_lookup`. Therefore we
explicitly disable `fixup-chains` by passing `-no_fixup_chains` to the linker on
darwin. This results in a warning of the form:
ld: warning: -undefined dynamic_lookup may not work with chained fixups
The manual explains the incompatible nature of these two flags:
-undefined treatment
Specifies how undefined symbols are to be treated. Options are: error, warning,
suppress, or dynamic_lookup. The default is error. Note: dynamic_lookup that
depends on lazy binding will not work with chained fixups.
A relevant ticket is #22429
Here are also a few other links which are relevant to the issue:
Official comment: https://developer.apple.com/forums/thread/719961
More relevant links:
https://openradar.appspot.com/radar?id=5536824084660224
https://github.com/python/cpython/issues/97524
Note in release notes: https://developer.apple.com/documentation/xcode-release-notes/xcode-13-releas e-notes
- - - - -
12 changed files:
- .gitlab/ci.sh
- .gitlab/darwin/toolchain.nix
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Core/Opt/FloatIn.hs
- configure.ac
- + m4/fp_ld_no_fixup_chains.m4
- rts/include/rts/storage/Closures.h
- testsuite/tests/ghci/linking/dyn/Makefile
- testsuite/tests/rts/T18623/all.T
- + testsuite/tests/simplCore/should_compile/T22662.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -213,10 +213,14 @@ function set_toolchain_paths() {
x86_64-darwin|aarch64-darwin) ;;
*) fail "unknown NIX_SYSTEM" ;;
esac
- nix build -f .gitlab/darwin/toolchain.nix --argstr system "$NIX_SYSTEM" -o toolchain.sh
+ info "Building toolchain for $NIX_SYSTEM"
+ nix-build .gitlab/darwin/toolchain.nix --argstr system "$NIX_SYSTEM" -o toolchain.sh
cat toolchain.sh
fi
- source toolchain.sh ;;
+ source toolchain.sh
+ info "--info for GHC for $NIX_SYSTEM"
+ $GHC --info
+ ;;
env)
# These are generally set by the Docker image but
# we provide these handy fallbacks in case the
@@ -320,7 +324,7 @@ function fetch_cabal() {
MINGW64) cabal_arch="x86_64" ;;
*) fail "unknown MSYSTEM $MSYSTEM" ;;
esac
- url="https://downloads.haskell.org/~cabal/cabal-install-$v/cabal-install-$v-$cabal_arch-unknown-mingw32.zip"
+ url="https://downloads.haskell.org/~cabal/cabal-install-$v/cabal-install-$v-$cabal_arch-windows.zip"
info "Fetching cabal binary distribution from $url..."
curl "$url" > "$TMP/cabal.zip"
unzip "$TMP/cabal.zip"
=====================================
.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:0p2f35pihlnmkm7x73b5xm3dyhiczrywc19khr7i7vb2q1y4zw6i";
+ sha256 = "sha256:10pby1idpxhkjqsi56jivkymhnabsdr8m2x8gdqchnv5113hl72k";
};
x86_64-darwin = pkgs.fetchurl {
url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-x86_64-apple-darwin.tar.xz";
- sha256 = "sha256:0gzq0vfjbhr9n8z63capvdwrw7bisy15d5c1y1gynfix13bbnjlk";
+ sha256 = "sha256:012yzyangk26sdapnz4226prgb8jgpf6k5bd9qxsdykk5x7jc7ah";
};
};
ghc = pkgs.stdenv.mkDerivation rec {
- version = "9.2.2";
+ version = "9.4.3";
name = "ghc";
src = ghcBindists.${pkgs.stdenv.hostPlatform.system};
configureFlags = [
@@ -38,6 +38,21 @@ let
];
buildPhase = "true";
+ # This is a horrible hack because the configure script invokes /usr/bin/clang
+ # without a `--target` flag. Then depending on whether the `nix` binary itself is
+ # a native x86 or arm64 binary means that /usr/bin/clang thinks it needs to run in
+ # x86 or arm64 mode.
+
+ # The correct answer for the check in question is the first one we try, so by replacing
+ # the condition to true; we select the right C++ standard library still.
+ preConfigure = ''
+ sed "s/\"\$CC\" -o actest actest.o \''${1} 2>\/dev\/null/true/i" configure > configure.new
+ mv configure.new configure
+ chmod +x configure
+ cat configure
+
+ '';
+
# N.B. Work around #20253.
nativeBuildInputs = [ pkgs.gnused ];
postInstallPhase = ''
@@ -98,6 +113,6 @@ pkgs.writeTextFile {
export CABAL="$CABAL_INSTALL"
sdk_path="$(xcrun --sdk macosx --show-sdk-path)"
- export CONFIGURE_ARGS="$CONFIGURE_ARGS --with-ffi-libraries=$sdk_path/usr/lib --with-ffi-includes=$sdk_path/usr/include/ffi"
+ export CONFIGURE_ARGS="$CONFIGURE_ARGS --with-ffi-libraries=$sdk_path/usr/lib --with-ffi-includes=$sdk_path/usr/include/ffi --build=${targetTriple}"
'';
}
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -349,8 +349,8 @@ opsysVariables _ FreeBSD13 = mconcat
-- [1] https://www.freebsd.org/doc/en/books/porters-handbook/using-iconv.html)
"CONFIGURE_ARGS" =: "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib"
, "HADRIAN_ARGS" =: "--docs=no-sphinx"
- , "GHC_VERSION" =: "9.2.2"
- , "CABAL_INSTALL_VERSION" =: "3.6.2.0"
+ , "GHC_VERSION" =: "9.4.3"
+ , "CABAL_INSTALL_VERSION" =: "3.8.1.0"
]
opsysVariables _ (Linux distro) = distroVariables distro
opsysVariables AArch64 (Darwin {}) =
@@ -378,8 +378,8 @@ opsysVariables _ (Windows {}) =
mconcat [ "MSYSTEM" =: "MINGW64"
, "HADRIAN_ARGS" =: "--docs=no-sphinx"
, "LANG" =: "en_US.UTF-8"
- , "CABAL_INSTALL_VERSION" =: "3.2.0.0"
- , "GHC_VERSION" =: "9.2.2" ]
+ , "CABAL_INSTALL_VERSION" =: "3.8.1.0"
+ , "GHC_VERSION" =: "9.4.3" ]
opsysVariables _ _ = mempty
=====================================
.gitlab/jobs.yaml
=====================================
@@ -594,9 +594,9 @@
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-freebsd13-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.6.2.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib ",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"TEST_ENV": "x86_64-freebsd13-validate",
"XZ_OPT": "-9"
@@ -1793,9 +1793,9 @@
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-x86_64-windows-int_native-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"LANG": "en_US.UTF-8",
"MSYSTEM": "MINGW64",
@@ -1852,9 +1852,9 @@
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-windows-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"LANG": "en_US.UTF-8",
"MSYSTEM": "MINGW64",
@@ -2225,9 +2225,9 @@
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-freebsd13-release",
"BUILD_FLAVOUR": "release",
- "CABAL_INSTALL_VERSION": "3.6.2.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib ",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"IGNORE_PERF_FAILURES": "all",
"TEST_ENV": "x86_64-freebsd13-release",
@@ -2957,9 +2957,9 @@
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-x86_64-windows-int_native-release+no_split_sections",
"BUILD_FLAVOUR": "release+no_split_sections",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"IGNORE_PERF_FAILURES": "all",
"LANG": "en_US.UTF-8",
@@ -3017,9 +3017,9 @@
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-windows-release+no_split_sections",
"BUILD_FLAVOUR": "release+no_split_sections",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"IGNORE_PERF_FAILURES": "all",
"LANG": "en_US.UTF-8",
@@ -3145,9 +3145,9 @@
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-freebsd13-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.6.2.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib ",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"TEST_ENV": "x86_64-freebsd13-validate"
}
@@ -4326,9 +4326,9 @@
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-x86_64-windows-int_native-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"LANG": "en_US.UTF-8",
"MSYSTEM": "MINGW64",
@@ -4384,9 +4384,9 @@
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-windows-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.8.1.0",
"CONFIGURE_ARGS": "",
- "GHC_VERSION": "9.2.2",
+ "GHC_VERSION": "9.4.3",
"HADRIAN_ARGS": "--docs=no-sphinx",
"LANG": "en_US.UTF-8",
"MSYSTEM": "MINGW64",
=====================================
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)
=====================================
configure.ac
=====================================
@@ -658,6 +658,11 @@ FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAG
FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE2],[CONF_GCC_LINKER_OPTS_STAGE2],[CONF_LD_LINKER_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
# Stage 3 won't be supported by cross-compilation
+FP_LD_NO_FIXUP_CHAINS([target], [LDFLAGS])
+FP_LD_NO_FIXUP_CHAINS([build], [CONF_GCC_LINKER_OPTS_STAGE0])
+FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE1])
+FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE2])
+
GHC_LLVM_TARGET_SET_VAR
# we intend to pass trough --targets to llvm as is.
LLVMTarget_CPP=` echo "$LlvmTarget"`
=====================================
m4/fp_ld_no_fixup_chains.m4
=====================================
@@ -0,0 +1,24 @@
+# FP_LD_NO_FIXUP_CHAINS
+# --------------------
+# See if whether we are using a version of ld64 on darwin platforms which
+# requires us to pass -no_fixup_chains
+#
+# $1 = the platform
+# $2 = the name of the linker flags variable when linking with $CC
+AC_DEFUN([FP_LD_NO_FIXUP_CHAINS], [
+ case $$1 in
+ *-darwin)
+ AC_MSG_CHECKING([whether ld64 requires -no_fixup_chains])
+ echo 'int main(void) {return 0;}' > conftest.c
+ if $CC -o conftest.o -Wl,-no_fixup_chains conftest.c > /dev/null 2>&1
+ then
+ $2="-Wl,-no_fixup_chains"
+ AC_MSG_RESULT([yes])
+ else
+ AC_MSG_RESULT([no])
+ fi
+ rm -f conftest.c conftest.o
+ ;;
+
+ esac
+])
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -211,8 +211,7 @@ typedef struct {
// An array of heap objects, ie Array# v and MutableArray# v
//
// Closure types: MUT_ARR_PTRS_CLEAN, MUT_ARR_PTRS_DIRTY,
-// MUT_ARR_PTRS_FROZEN_DIRTY, MUT_ARR_PTRS_FROZEN_CLEAN, MUT_VAR_CLEAN,
-// MUT_VAR_DIRTY
+// MUT_ARR_PTRS_FROZEN_DIRTY, MUT_ARR_PTRS_FROZEN_CLEAN
typedef struct _StgMutArrPtrs {
StgHeader header;
StgWord ptrs;
=====================================
testsuite/tests/ghci/linking/dyn/Makefile
=====================================
@@ -84,7 +84,7 @@ compile_libAB_dyn:
'$(TEST_HC)' $(MY_TEST_HC_OPTS) -odir "bin_dyn" -shared B.c -o "bin_dyn/$(call DLL,B)" $(call DEF,B) -lA -L"./bin_dyn"
rm -f bin_dyn/*.a
'$(TEST_HC)' $(TEST_HC_OPTS) -ignore-dot-ghci -v0 -o "bin_dyn/$(call EXE,T10955dyn)" -L./bin_dyn -lB -lA T10955dyn.hs -v0
- LD_LIBRARY_PATH=./bin_dyn ./bin_dyn/$(call EXE,T10955dyn)
+ DYLD_LIBRARY_PATH=./bin_dyn LD_LIBRARY_PATH=./bin_dyn ./bin_dyn/$(call EXE,T10955dyn)
.PHONY: compile_libAS_impl_gcc
compile_libAS_impl_gcc:
=====================================
testsuite/tests/rts/T18623/all.T
=====================================
@@ -5,6 +5,8 @@ test('T18623',
# This keeps failing on aarch64-linux for reasons that are not
# fully clear. Maybe it needs a higher limit due to LLVM?
when(arch('aarch64'), skip),
+ # Recent versions of osx report an error when running `ulimit -v`
+ when(arch('darwin'), skip),
when(arch('powerpc64le'), skip),
cmd_prefix('ulimit -v ' + str(1024 ** 2) + ' && '),
ignore_stdout],
=====================================
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/all.T
=====================================
@@ -461,3 +461,4 @@ 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('T22662', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f4b9155d2e90c343bf3edc4e8ec2eb7e18c2560...857c2404e892725cd344889b177cc732571d84cc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f4b9155d2e90c343bf3edc4e8ec2eb7e18c2560...857c2404e892725cd344889b177cc732571d84cc
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/20230107/2405854a/attachment-0001.html>
More information about the ghc-commits
mailing list