[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Make FloatIn robust to shadowing
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Jan 8 22:25:51 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
6206cb92 by Simon Peyton Jones at 2023-01-07T12:14:40-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
- - - - -
a960ca81 by Matthew Pickering at 2023-01-07T12:15:15-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
- - - - -
73484710 by Matthew Pickering at 2023-01-07T12:15:15-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.
- - - - -
8c0ea25f by Matthew Pickering at 2023-01-07T12:15:15-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
- - - - -
18c9fb08 by Matthew Pickering at 2023-01-08T17:25:37-05:00
Disable split sections on aarch64-deb10 build
See #22722
Failure on this job:
https://gitlab.haskell.org/ghc/ghc/-/jobs/1287852
```
Unexpected failures:
/builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T10828.run T10828 [exit code non-0] (ext-interp)
/builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T13123.run T13123 [exit code non-0] (ext-interp)
/builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T20590.run T20590 [exit code non-0] (ext-interp)
Appending 232 stats to file: /builds/ghc/ghc/performance-metrics.tsv
```
```
Compile failed (exit code 1) errors were:
data family D_0 a_1 :: * -> *
data instance D_0 GHC.Types.Int GHC.Types.Bool :: * where
DInt_2 :: D_0 GHC.Types.Int GHC.Types.Bool
data E_3 where MkE_4 :: a_5 -> E_3
data Foo_6 a_7 b_8 where
MkFoo_9, MkFoo'_10 :: a_11 -> Foo_6 a_11 b_12
newtype Bar_13 :: * -> GHC.Types.Bool -> * where
MkBar_14 :: a_15 -> Bar_13 a_15 b_16
data T10828.T (a_0 :: *) where
T10828.MkT :: forall (a_1 :: *) . a_1 -> a_1 -> T10828.T a_1
T10828.MkC :: forall (a_2 :: *) (b_3 :: *) . (GHC.Types.~) a_2
GHC.Types.Int => {T10828.foo :: a_2,
T10828.bar :: b_3} -> T10828.T GHC.Types.Int
T10828.hs:1:1: error: [GHC-87897]
Exception when trying to run compile-time code:
ghc-iserv terminated (-4)
Code: (do TyConI dec <- runQ $ reify (mkName "T")
runIO $ putStrLn (pprint dec) >> hFlush stdout
d <- runQ
$ [d| data T' a :: Type
where
MkT' :: a -> a -> T' a
MkC' :: forall a b. (a ~ Int) => {foo :: a, bar :: b} -> T' Int |]
runIO $ putStrLn (pprint d) >> hFlush stdout
....)
*** unexpected failure for T10828(ext-interp)
=====> 7000 of 9215 [0, 1, 0]
=====> 7000 of 9215 [0, 1, 0]
=====> 7000 of 9215 [0, 1, 0]
=====> 7000 of 9215 [0, 1, 0]
Compile failed (exit code 1) errors were:
T13123.hs:1:1: error: [GHC-87897]
Exception when trying to run compile-time code:
ghc-iserv terminated (-4)
Code: ([d| data GADT
where MkGADT :: forall k proxy (a :: k). proxy a -> GADT |])
*** unexpected failure for T13123(ext-interp)
=====> 7100 of 9215 [0, 2, 0]
=====> 7100 of 9215 [0, 2, 0]
=====> 7200 of 9215 [0, 2, 0]
Compile failed (exit code 1) errors were:
T20590.hs:1:1: error: [GHC-87897]
Exception when trying to run compile-time code:
ghc-iserv terminated (-4)
Code: ([d| data T where MkT :: forall a. a -> T |])
*** unexpected failure for T20590(ext-interp)
```
Looks fairly worrying to me.
- - - - -
521cc499 by Alan Zimmerman at 2023-01-08T17:25:37-05:00
EPA: exact print HsDocTy
To match ghc-exactprint
https://github.com/alanz/ghc-exactprint/pull/121
- - - - -
14 changed files:
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Core/Opt/FloatIn.hs
- configure.ac
- + m4/fp_ld_no_fixup_chains.m4
- testsuite/tests/ghci/linking/dyn/Makefile
- + testsuite/tests/printer/HsDocTy.hs
- testsuite/tests/printer/Makefile
- testsuite/tests/printer/all.T
- testsuite/tests/rts/T18623/all.T
- + testsuite/tests/simplCore/should_compile/T22662.hs
- testsuite/tests/simplCore/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -813,7 +813,7 @@ jobs = Map.fromList $ concatMap flattenJobGroup $
, standardBuilds Amd64 Darwin
, allowFailureGroup (addValidateRule FreeBSDLabel (standardBuilds Amd64 FreeBSD13))
, standardBuilds AArch64 Darwin
- , standardBuilds AArch64 (Linux Debian10)
+ , standardBuildsWithConfig AArch64 (Linux Debian10) (splitSectionsBroken vanilla)
, disableValidate (standardBuildsWithConfig AArch64 (Linux Debian10) llvm)
, standardBuildsWithConfig I386 (Linux Debian9) (splitSectionsBroken vanilla)
, standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken static)
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1926,7 +1926,7 @@
"XZ_OPT": "-9"
}
},
- "release-aarch64-linux-deb10-release": {
+ "release-aarch64-linux-deb10-release+llvm": {
"after_script": [
".gitlab/ci.sh save_cache",
".gitlab/ci.sh clean",
@@ -1936,7 +1936,7 @@
"artifacts": {
"expire_in": "1 year",
"paths": [
- "ghc-aarch64-linux-deb10-release.tar.xz",
+ "ghc-aarch64-linux-deb10-release+llvm.tar.xz",
"junit.xml"
],
"reports": {
@@ -1978,15 +1978,15 @@
],
"variables": {
"BIGNUM_BACKEND": "gmp",
- "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release",
- "BUILD_FLAVOUR": "release",
+ "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release+llvm",
+ "BUILD_FLAVOUR": "release+llvm",
"CONFIGURE_ARGS": "",
"IGNORE_PERF_FAILURES": "all",
- "TEST_ENV": "aarch64-linux-deb10-release",
+ "TEST_ENV": "aarch64-linux-deb10-release+llvm",
"XZ_OPT": "-9"
}
},
- "release-aarch64-linux-deb10-release+llvm": {
+ "release-aarch64-linux-deb10-release+no_split_sections": {
"after_script": [
".gitlab/ci.sh save_cache",
".gitlab/ci.sh clean",
@@ -1996,7 +1996,7 @@
"artifacts": {
"expire_in": "1 year",
"paths": [
- "ghc-aarch64-linux-deb10-release+llvm.tar.xz",
+ "ghc-aarch64-linux-deb10-release+no_split_sections.tar.xz",
"junit.xml"
],
"reports": {
@@ -2038,11 +2038,11 @@
],
"variables": {
"BIGNUM_BACKEND": "gmp",
- "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release+llvm",
- "BUILD_FLAVOUR": "release+llvm",
+ "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release+no_split_sections",
+ "BUILD_FLAVOUR": "release+no_split_sections",
"CONFIGURE_ARGS": "",
"IGNORE_PERF_FAILURES": "all",
- "TEST_ENV": "aarch64-linux-deb10-release+llvm",
+ "TEST_ENV": "aarch64-linux-deb10-release+no_split_sections",
"XZ_OPT": "-9"
}
},
=====================================
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
+])
=====================================
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/printer/HsDocTy.hs
=====================================
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -haddock #-}
+module HsDocTy where
+
+class C1 a where
+ f1 :: a -> Int
+ -- ^ comment on Int
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -769,3 +769,9 @@ Test21355:
Test21805:
$(CHECK_PPR) $(LIBDIR) Test21805.hs
$(CHECK_EXACT) $(LIBDIR) Test21805.hs
+
+.PHONY: HsDocTy
+HsDocTy:
+ # See comment on pprWithDocString, this won't round trip
+ # $(CHECK_PPR) $(LIBDIR) HsDocTy.hs
+ $(CHECK_EXACT) $(LIBDIR) HsDocTy.hs
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -185,4 +185,5 @@ test('Test21805', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21805'])
test('T22488', normal, ghci_script, ['T22488.script'])
test('T22488_docHead', normal, compile_and_run, ['-package ghc'])
test('T20531', extra_files(['T20531_defs.hs']), ghci_script, ['T20531.script'])
-test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_red_ticks.script'])
\ No newline at end of file
+test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_red_ticks.script'])
+test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
\ No newline at end of file
=====================================
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, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3898,6 +3898,10 @@ instance ExactPrint (HsType GhcPs) where
exact (HsSpliceTy a splice) = do
splice' <- markAnnotated splice
return (HsSpliceTy a splice')
+ exact (HsDocTy an ty doc) = do
+ ty' <- markAnnotated ty
+ doc' <- markAnnotated doc
+ return (HsDocTy an ty' doc')
exact (HsBangTy an (HsSrcBang mt up str) ty) = do
an0 <-
case mt of
=====================================
utils/check-exact/Main.hs
=====================================
@@ -59,7 +59,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3)
-- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls)
- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
+ -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" (Just changeWhereIn3a)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" (Just changeWhereIn3b)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" (Just addLocaLDecl1)
@@ -203,6 +203,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
-- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
+ "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- cloneT does not need a test, function can be retired
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/857c2404e892725cd344889b177cc732571d84cc...521cc49949866a7d74445cb20debab9f60da532f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/857c2404e892725cd344889b177cc732571d84cc...521cc49949866a7d74445cb20debab9f60da532f
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/20230108/7cf99167/attachment-0001.html>
More information about the ghc-commits
mailing list