[Git][ghc/ghc][wip/js-rts-fixmes] 14 commits: JS generated refs: update testsuite conditions
Josh Meredith (@JoshMeredith)
gitlab at gitlab.haskell.org
Sun Feb 12 16:37:19 UTC 2023
Josh Meredith pushed to branch wip/js-rts-fixmes at Glasgow Haskell Compiler / GHC
Commits:
d69ecac2 by Josh Meredith at 2023-02-09T03:24:05-05:00
JS generated refs: update testsuite conditions
- - - - -
2ea1a6bc by sheaf at 2023-02-09T03:24:44-05:00
Bump transformers to 0.6.1.0
This allows us to avoid orphans for Foldable1 instances,
fixing #22898.
Updates transformers submodule.
- - - - -
d9d0c28d by konsumlamm at 2023-02-09T14:07:48-05:00
Update `Data.List.singleton` doc comment
- - - - -
fe9cd6ef by Ben Gamari at 2023-02-09T14:08:23-05:00
gitlab-template: Emphasize `user facing` label
My sense is that the current mention of the ~"user facing" label is
overlooked by many MR authors.
Let's move this point up in the list to make it more likely that it is
seen. Also rephrase some of the points.
- - - - -
e45eb828 by Simon Peyton Jones at 2023-02-10T06:51:28-05:00
Refactor the simplifier a bit to fix #22761
The core change in this commit, which fixes #22761, is that
* In a Core rule, ru_rhs is always occ-analysed.
This means adding a couple of calls to occurAnalyseExpr when
building a Rule, in
* GHC.Core.Rules.mkRule
* GHC.Core.Opt.Simplify.Iteration.simplRules
But diagosing the bug made me stare carefully at the code of the
Simplifier, and I ended up doing some only-loosely-related refactoring.
* I think that RULES could be lost because not every code path
did addBndrRules
* The code around lambdas was very convoluted
It's mainly moving deck chairs around, but I like it more now.
- - - - -
11e0cacb by Rebecca Turner at 2023-02-10T06:52:09-05:00
Detect the `mold` linker
Enables support for the `mold` linker by rui314.
- - - - -
59556235 by parsonsmatt at 2023-02-10T09:53:11-05:00
Add Lift instance for Fixed
- - - - -
c44e5f30 by Sylvain Henry at 2023-02-10T09:53:51-05:00
Testsuite: decrease length001 timeout for JS (#22921)
- - - - -
133516af by Zubin Duggal at 2023-02-10T09:54:27-05:00
compiler: Use NamedFieldPuns for `ModIface_` and `ModIfaceBackend` `NFData`
instances
This is a minor refactor that makes it easy to add and remove fields from
`ModIface_` and `ModIfaceBackend`.
Also change the formatting to make it clear exactly which fields are
fully forced with `rnf`
- - - - -
ad9913f5 by Josh Meredith at 2023-02-12T16:36:30+00:00
Factor JS Rts generation for h$c{_,0,1,2} into h$c{n}
- - - - -
c66f45eb by Josh Meredith at 2023-02-12T16:36:30+00:00
Cache names used commonly in JS backend RTS generation
- - - - -
49117183 by Sylvain Henry at 2023-02-12T16:36:30+00:00
Apply 1 suggestion(s) to 1 file(s)
- - - - -
079132b0 by Josh Meredith at 2023-02-12T16:36:30+00:00
JS/Make: reduce cache sizes
- - - - -
c0791ba3 by Josh Meredith at 2023-02-12T16:36:52+00:00
JS RTS: use jsClosureCount for closureConstructors and cache sizes
- - - - -
29 changed files:
- .gitlab/merge_request_templates/merge-request.md
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/JS/Make.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/SysTools/Info.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Unit/Module/ModIface.hs
- libraries/base/Data/OldList.hs
- libraries/base/tests/all.T
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- libraries/transformers
- testsuite/driver/testlib.py
- testsuite/tests/driver/T1959/test.T
- testsuite/tests/ffi/should_run/all.T
- testsuite/tests/rts/all.T
- testsuite/tests/safeHaskell/check/pkg01/all.T
- + testsuite/tests/simplCore/should_compile/T22761.hs
- + testsuite/tests/simplCore/should_compile/T22761a.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitlab/merge_request_templates/merge-request.md
=====================================
@@ -5,18 +5,19 @@ expectations. Also please answer the following question in your MR description:*
**Where is the key part of this patch? That is, what should reviewers look at first?**
-Please take a few moments to verify that your commits fulfill the following:
+Please take a few moments to address the following points:
- * [ ] are either individually buildable or squashed
- * [ ] have commit messages which describe *what they do*
- (referring to [Notes][notes] and tickets using `#NNNN` syntax when
- appropriate)
+ * [ ] if your MR may break existing programs (e.g. touches `base` or causes the
+ compiler to reject programs), please describe the expected breakage and add
+ the ~"user facing" label. This will run ghc/head.hackage> to characterise
+ the effect of your change on Hackage.
+ * [ ] ensure that your commits are either individually buildable or squashed
+ * [ ] ensure that your commit messages describe *what they do*
+ (referring to tickets using `#NNNN` syntax when appropriate)
* [ ] have added source comments describing your change. For larger changes you
likely should add a [Note][notes] and cross-reference it from the relevant
places.
- * [ ] add a [testcase to the testsuite](https://gitlab.haskell.org/ghc/ghc/wikis/building/running-tests/adding).
- * [ ] if your MR affects library interfaces (e.g. changes `base`) or affects whether GHC will accept user-written code, please add
- the ~"user facing" label.
+ * [ ] add a [testcase to the testsuite][adding test].
* [ ] updates the users guide if applicable
* [ ] mentions new features in the release notes for the next release
@@ -29,3 +30,4 @@ no one has offerred review in a few days then please leave a comment mentioning
@triagers.
[notes]: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/coding-style#comments-in-the-source-code
+[adding test]: https://gitlab.haskell.org/ghc/ghc/wikis/building/running-tests/adding
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1300,16 +1300,19 @@ data Unfolding
df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods,
} -- in positional order
- | CoreUnfolding { -- An unfolding for an Id with no pragma,
- -- or perhaps a NOINLINE pragma
- -- (For NOINLINE, the phase, if any, is in the
- -- InlinePragInfo for this Id.)
- uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
- uf_src :: UnfoldingSource, -- Where the unfolding came from
- uf_is_top :: Bool, -- True <=> top level binding
- uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr
- -- See Note [Tying the 'CoreUnfolding' knot]
- uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
+ | CoreUnfolding { -- An unfolding for an Id with no pragma,
+ -- or perhaps a NOINLINE pragma
+ -- (For NOINLINE, the phase, if any, is in the
+ -- InlinePragInfo for this Id.)
+ uf_tmpl :: CoreExpr, -- The unfolding itself (aka "template")
+ -- Always occ-analysed;
+ -- See Note [OccInfo in unfoldings and rules]
+
+ uf_src :: UnfoldingSource, -- Where the unfolding came from
+ uf_is_top :: Bool, -- True <=> top level binding
+ uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr
+ -- See Note [Tying the 'CoreUnfolding' knot]
+ uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
}
-- ^ An unfolding with redundant cached information. Parameters:
--
@@ -1637,14 +1640,37 @@ change was requested by Roman, but it seems to make sense.
Note [OccInfo in unfoldings and rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In unfoldings and rules, we guarantee that the template is occ-analysed,
-so that the occurrence info on the binders is correct. This is important,
-because the Simplifier does not re-analyse the template when using it. If
-the occurrence info is wrong
- - We may get more simplifier iterations than necessary, because
- once-occ info isn't there
- - More seriously, we may get an infinite loop if there's a Rec
- without a loop breaker marked
+In unfoldings and rules, we guarantee that the template is occ-analysed, so
+that the occurrence info on the binders is correct. That way, when the
+Simplifier inlines an unfolding, it doesn't need to occ-analysis it first.
+(The Simplifier is designed to simplify occ-analysed expressions.)
+
+Given this decision it's vital that we do *always* do it.
+
+* If we don't, we may get more simplifier iterations than necessary,
+ because once-occ info isn't there
+
+* More seriously, we may get an infinite loop if there's a Rec without a
+ loop breaker marked.
+
+* Or we may get code that mentions variables not in scope: #22761
+ e.g. Suppose we have a stable unfolding : \y. let z = p+1 in 3
+ Then the pre-simplifier occ-anal will occ-anal the unfolding
+ (redundantly perhaps, but we need its free vars); this will not report
+ the use of `p`; so p's binding will be discarded, and yet `p` is still
+ mentioned.
+
+ Better to occ-anal the unfolding at birth, which will drop the
+ z-binding as dead code. (Remember, it's the occurrence analyser that
+ drops dead code.)
+
+* Another example is #8892:
+ \x -> letrec { f = ...g...; g* = f } in body
+ where g* is (for some strange reason) the loop breaker. If we don't
+ occ-anal it when reading it in, we won't mark g as a loop breaker, and we
+ may inline g entirely in body, dropping its binding, and leaving the
+ occurrence in f out of scope. This happened in #8892, where the unfolding
+ in question was a DFun unfolding.
************************************************************************
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -3088,8 +3088,15 @@ etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs
| need_args < 0
= pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)
| otherwise
- = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args
- , ru_rhs = new_rhs }
+ = rule { ru_bndrs = bndrs ++ new_bndrs
+ , ru_args = args ++ new_args
+ , ru_rhs = new_rhs }
+ -- new_rhs really ought to be occ-analysed (see GHC.Core Note
+ -- [OccInfo in unfoldings and rules]), but it makes a module loop to
+ -- do so; it doesn't happen often; and it doesn't really matter if
+ -- the outer binders have bogus occurrence info; and new_rhs won't
+ -- have dead code if rhs didn't.
+
where
need_args = join_arity - length args
(new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -2165,6 +2165,17 @@ So we have a fast-path that keeps the old tree if the occ_bs_env is
empty. This just saves a bit of allocation and reconstruction; not
a big deal.
+This fast path exposes a tricky cornder, though (#22761). Supose we have
+ Unfolding = \x. let y = foo in x+1
+which includes a dead binding for `y`. In occAnalUnfolding we occ-anal
+the unfolding and produce /no/ occurrences of `foo` (since `y` is
+dead). But if we discard the occ-analysed syntax tree (which we do on
+our fast path), and use the old one, we still /have/ an occurrence of
+`foo` -- and that can lead to out-of-scope variables (#22761).
+
+Solution: always keep occ-analysed trees in unfoldings and rules, so they
+have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core.
+
Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
By default we use an rhsCtxt for the RHS of a binding. This tells the
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -1065,7 +1065,7 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
-- See Note [Bangs in the Simplifier]
!id1 = uniqAway in_scope old_id
!id2 = substIdType env id1
- !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
-- and fragile OccInfo
!new_id = adjust_type id3
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -319,14 +319,14 @@ simplLazyBind :: SimplEnv
-> TopLevelFlag -> RecFlag
-> InId -> OutId -- Binder, both pre-and post simpl
-- Not a JoinId
- -- The OutId has IdInfo, except arity, unfolding
+ -- The OutId has IdInfo (notably RULES),
+ -- except arity, unfolding
-- Ids only, no TyVars
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM (SimplFloats, SimplEnv)
-- Precondition: the OutId is already in the InScopeSet of the incoming 'env'
-- Precondition: not a JoinId
-- Precondition: rhs obeys the let-can-float invariant
--- NOT used for JoinIds
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= assert (isId bndr )
assertPpr (not (isJoinId bndr)) (ppr bndr) $
@@ -398,48 +398,45 @@ simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se
; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' }
--------------------------
-simplNonRecX :: SimplEnv
+simplAuxBind :: SimplEnv
-> InId -- Old binder; not a JoinId
-> OutExpr -- Simplified RHS
-> SimplM (SimplFloats, SimplEnv)
--- A specialised variant of simplNonRec used when the RHS is already
--- simplified, notably in knownCon. It uses case-binding where necessary.
+-- A specialised variant of completeBindX used to construct non-recursive
+-- auxiliary bindings, notably in knownCon.
+--
+-- The binder comes from a case expression (case binder or alternative)
+-- and so does not have rules, inline pragmas etc.
--
-- Precondition: rhs satisfies the let-can-float invariant
-simplNonRecX env bndr new_rhs
- | assertPpr (not (isJoinId bndr)) (ppr bndr) $
+simplAuxBind env bndr new_rhs
+ | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $
isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
= return (emptyFloats env, env) -- Here c is dead, and we avoid
- -- creating the binding c = (a,b)
-
- | Coercion co <- new_rhs
- = return (emptyFloats env, extendCvSubst env bndr co)
+ -- creating the binding c = (a,b)
+ -- The cases would be inlined unconditionally by completeBind:
+ -- but it seems not uncommon, and avoids faff to do it here
+ -- This is safe because it's only used for auxiliary bindings, which
+ -- have no NOLINE pragmas, nor RULEs
| exprIsTrivial new_rhs -- Short-cut for let x = y in ...
- -- This case would ultimately land in postInlineUnconditionally
- -- but it seems not uncommon, and avoids a lot of faff to do it here
- = return (emptyFloats env
- , extendIdSubst env bndr (DoneEx new_rhs Nothing))
+ = return ( emptyFloats env
+ , case new_rhs of
+ Coercion co -> extendCvSubst env bndr co
+ _ -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )
| otherwise
- = do { (env1, new_bndr) <- simplBinder env bndr
- ; let is_strict = isStrictId new_bndr
- -- isStrictId: use new_bndr because the InId bndr might not have
- -- a fixed runtime representation, which isStrictId doesn't expect
- -- c.f. Note [Dark corner with representation polymorphism]
-
- ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
- new_bndr (emptyFloats env) new_rhs
- -- NB: it makes a surprisingly big difference (5% in compiler allocation
- -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
- -- because this is simplNonRecX, so bndr is not in scope in the RHS.
-
- ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)
- (BC_Let NotTopLevel NonRecursive)
+ = do { -- ANF-ise the RHS
+ let !occ_fs = getOccFS bndr
+ ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs
+ ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)
+ ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats
+
+ -- Simplify the binder and complete the binding
+ ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr
+ ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive)
bndr new_bndr rhs1
- -- Must pass env1 to completeBind in case simplBinder had to clone,
- -- and extended the substitution with [bndr :-> new_bndr]
; return (rhs_floats `addFloats` bind_float, env2) }
@@ -761,49 +758,54 @@ prepareRhs :: HasDebugCallStack
-- x = Just a
-- See Note [prepareRhs]
prepareRhs env top_lvl occ rhs0
- = do { (_is_exp, floats, rhs1) <- go 0 rhs0
- ; return (floats, rhs1) }
+ | is_expandable = anfise rhs0
+ | otherwise = return (emptyLetFloats, rhs0)
where
- go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)
- go n_val_args (Cast rhs co)
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
- ; return (is_exp, floats, Cast rhs' co) }
- go n_val_args (App fun (Type ty))
- = do { (is_exp, floats, rhs') <- go n_val_args fun
- ; return (is_exp, floats, App rhs' (Type ty)) }
- go n_val_args (App fun arg)
- = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun
- ; if is_exp
- then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg
- ; return (True, floats1 `addLetFlts` floats2, App fun' arg') }
- else return (False, emptyLetFloats, App fun arg)
- }
- go n_val_args (Var fun)
- = return (is_exp, emptyLetFloats, Var fun)
- where
- is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
- -- See Note [CONLIKE pragma] in GHC.Types.Basic
- -- The definition of is_exp should match that in
- -- 'GHC.Core.Opt.OccurAnal.occAnalApp'
-
- go n_val_args (Tick t rhs)
+ -- We can' use exprIsExpandable because the WHOLE POINT is that
+ -- we want to treat (K <big>) as expandable, because we are just
+ -- about "anfise" the <big> expression. exprIsExpandable would
+ -- just say no!
+ is_expandable = go rhs0 0
+ where
+ go (Var fun) n_val_args = isExpandableApp fun n_val_args
+ go (App fun arg) n_val_args
+ | isTypeArg arg = go fun n_val_args
+ | otherwise = go fun (n_val_args + 1)
+ go (Cast rhs _) n_val_args = go rhs n_val_args
+ go (Tick _ rhs) n_val_args = go rhs n_val_args
+ go _ _ = False
+
+ anfise :: OutExpr -> SimplM (LetFloats, OutExpr)
+ anfise (Cast rhs co)
+ = do { (floats, rhs') <- anfise rhs
+ ; return (floats, Cast rhs' co) }
+ anfise (App fun (Type ty))
+ = do { (floats, rhs') <- anfise fun
+ ; return (floats, App rhs' (Type ty)) }
+ anfise (App fun arg)
+ = do { (floats1, fun') <- anfise fun
+ ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg
+ ; return (floats1 `addLetFlts` floats2, App fun' arg') }
+ anfise (Var fun)
+ = return (emptyLetFloats, Var fun)
+
+ anfise (Tick t rhs)
-- We want to be able to float bindings past this
-- tick. Non-scoping ticks don't care.
| tickishScoped t == NoScope
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
- ; return (is_exp, floats, Tick t rhs') }
+ = do { (floats, rhs') <- anfise rhs
+ ; return (floats, Tick t rhs') }
-- On the other hand, for scoping ticks we need to be able to
-- copy them on the floats, which in turn is only allowed if
-- we can obtain non-counting ticks.
| (not (tickishCounts t) || tickishCanSplit t)
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
+ = do { (floats, rhs') <- anfise rhs
; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
floats' = mapLetFloats floats tickIt
- ; return (is_exp, floats', Tick t rhs') }
+ ; return (floats', Tick t rhs') }
- go _ other
- = return (False, emptyLetFloats, other)
+ anfise other = return (emptyLetFloats, other)
makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })
@@ -1244,7 +1246,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont
| otherwise
= {-#SCC "simplNonRecE" #-}
- simplNonRecE env False bndr (rhs, env) body cont
+ simplNonRecE env FromLet bndr (rhs, env) body cont
{- Note [Avoiding space leaks in OutType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1505,8 +1507,9 @@ rebuild env expr cont
StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
-> rebuildCall env (addValArgTo fun expr fun_ty ) cont
- StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont }
- -> completeBindX (se `setInScopeFromE` env) b expr body cont
+ StrictBind { sc_bndr = b, sc_body = body, sc_env = se
+ , sc_cont = cont, sc_from = from_what }
+ -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont
ApplyToTy { sc_arg_ty = ty, sc_cont = cont}
-> rebuild env (App expr (Type ty)) cont
@@ -1518,25 +1521,48 @@ rebuild env expr cont
; rebuild env (App expr arg') cont }
completeBindX :: SimplEnv
+ -> FromWhat
-> InId -> OutExpr -- Bind this Id to this (simplified) expression
-- (the let-can-float invariant may not be satisfied)
- -> InExpr -- In this lambda
+ -> InExpr -- In this body
-> SimplCont -- Consumed by this continuation
-> SimplM (SimplFloats, OutExpr)
-completeBindX env bndr rhs body cont
- | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant
- = do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; (floats, expr') <- simplLam env1 body cont
+completeBindX env from_what bndr rhs body cont
+ | FromBeta arg_ty <- from_what
+ , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules
+ ; (floats, expr') <- simplNonRecBody env1 from_what body cont
-- Do not float floats past the Case binder below
; let expr'' = wrapFloats floats expr'
- ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']
+ case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']
; return (emptyFloats env, case_expr) }
- | otherwise
- = do { (floats1, env') <- simplNonRecX env bndr rhs
- ; (floats2, expr') <- simplLam env' body cont
- ; return (floats1 `addFloats` floats2, expr') }
+ | otherwise -- Make a let-binding
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+
+ ; let is_strict = isStrictId bndr2
+ -- isStrictId: use simplified binder because the InId bndr might not have
+ -- a fixed runtime representation, which isStrictId doesn't expect
+ -- c.f. Note [Dark corner with representation polymorphism]
+
+ ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
+ bndr2 (emptyFloats env) rhs
+ -- NB: it makes a surprisingly big difference (5% in compiler allocation
+ -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
+ -- because this is simplNonRecX, so bndr is not in scope in the RHS.
+
+ ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats)
+ (BC_Let NotTopLevel NonRecursive)
+ bndr bndr2 rhs1
+ -- Must pass env1 to completeBind in case simplBinder had to clone,
+ -- and extended the substitution with [bndr :-> new_bndr]
+
+ -- Simplify the body
+ ; (body_floats, body') <- simplNonRecBody env2 from_what body cont
+ ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats
+ ; return ( all_floats, body' ) }
{-
************************************************************************
@@ -1674,6 +1700,14 @@ simplArg env dup_flag fun_ty arg_env arg
************************************************************************
-}
+simplNonRecBody :: SimplEnv -> FromWhat
+ -> InExpr -> SimplCont
+ -> SimplM (SimplFloats, OutExpr)
+simplNonRecBody env from_what body cont
+ = case from_what of
+ FromLet -> simplExprF env body cont
+ FromBeta {} -> simplLam env body cont
+
simplLam :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
@@ -1690,15 +1724,24 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
-- Value beta-reduction
simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_cont = cont, sc_dup = dup })
- | isSimplified dup -- Don't re-simplify if we've simplified it once
- -- See Note [Avoiding exponential behaviour]
+ , sc_cont = cont, sc_dup = dup
+ , sc_hole_ty = fun_ty})
= do { tick (BetaReduction bndr)
- ; completeBindX env bndr arg body cont }
+ ; let arg_ty = funArgTy fun_ty
+ ; if | isSimplified dup -- Don't re-simplify if we've simplified it once
+ -- Including don't preInlineUnconditionally
+ -- See Note [Avoiding exponential behaviour]
+ -> completeBindX env (FromBeta arg_ty) bndr arg body cont
+
+ | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se
+ , not (needsCaseBinding arg_ty arg)
+ -- Ok to test arg::InExpr in needsCaseBinding because
+ -- exprOkForSpeculation is stable under simplification
+ -> do { tick (PreInlineUnconditionally bndr)
+ ; simplLam env' body cont }
- | otherwise -- See Note [Avoiding exponential behaviour]
- = do { tick (BetaReduction bndr)
- ; simplNonRecE env True bndr (arg, arg_se) body cont }
+ | otherwise
+ -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont }
-- Discard a non-counting tick on a lambda. This may change the
-- cost attribution slightly (moving the allocation of the
@@ -1730,8 +1773,7 @@ simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
------------------
simplNonRecE :: SimplEnv
- -> Bool -- True <=> from a lambda
- -- False <=> from a let
+ -> FromWhat
-> InId -- The binder, always an Id
-- Never a join point
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
@@ -1740,56 +1782,48 @@ simplNonRecE :: SimplEnv
-> SimplM (SimplFloats, OutExpr)
-- simplNonRecE is used for
--- * non-top-level non-recursive non-join-point lets in expressions
--- * beta reduction
+-- * from=FromLet: a non-top-level non-recursive non-join-point let-expression
+-- * from=FromBeta: a binding arising from a beta reduction
--
--- simplNonRec env b (rhs, rhs_se) body k
+-- simplNonRecE env b (rhs, rhs_se) body k
-- = let env in
-- cont< let b = rhs_se(rhs) in body >
--
-- It deals with strict bindings, via the StrictBind continuation,
-- which may abort the whole process.
--
--- from_lam=False => the RHS satisfies the let-can-float invariant
+-- from_what=FromLet => the RHS satisfies the let-can-float invariant
-- Otherwise it may or may not satisfy it.
-simplNonRecE env from_lam bndr (rhs, rhs_se) body cont
- = assert (isId bndr && not (isJoinId bndr) ) $
- do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs
- -- See Note [Dark corner with representation polymorphism]
- -- If from_lam=False then needs_case_binding is False,
- -- because the binding started as a let, which must
- -- satisfy let-can-float
-
- ; if | from_lam && not needs_case_binding
- -- If not from_lam we are coming from a (NonRec bndr rhs) binding
- -- and preInlineUnconditionally has been done already;
- -- no need to repeat it. But for lambdas we must be careful about
- -- preInlineUndonditionally: consider (\(x:Int#). 3) (error "urk")
- -- We must not drop the (error "urk").
- , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se
- -> do { tick (PreInlineUnconditionally bndr)
- ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
- simplLam env' body cont }
-
- -- Deal with strict bindings
- | isStrictId bndr1 && seCaseCase env
- || from_lam && needs_case_binding
- -- The important bit here is needs_case_binds; but no need to
- -- test it if from_lam is False because then needs_case_binding is False too
- -- NB: either way, the RHS may or may not satisfy let-can-float
- -- but that's ok for StrictBind.
- -> simplExprF (rhs_se `setInScopeFromE` env) rhs
- (StrictBind { sc_bndr = bndr, sc_body = body
- , sc_env = env, sc_cont = cont, sc_dup = NoDup })
-
- -- Deal with lazy bindings
- | otherwise
- -> do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
- ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
- ; (floats2, expr') <- simplLam env3 body cont
- ; return (floats1 `addFloats` floats2, expr') } }
+simplNonRecE env from_what bndr (rhs, rhs_se) body cont
+ | assert (isId bndr && not (isJoinId bndr) ) $
+ is_strict_bind
+ = -- Evaluate RHS strictly
+ simplExprF (rhs_se `setInScopeFromE` env) rhs
+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
+ , sc_env = env, sc_cont = cont, sc_dup = NoDup })
+
+ | otherwise -- Evaluate RHS lazily
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+ ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive
+ bndr bndr2 rhs rhs_se
+ ; (floats2, expr') <- simplNonRecBody env3 from_what body cont
+ ; return (floats1 `addFloats` floats2, expr') }
+
+ where
+ is_strict_bind = case from_what of
+ FromBeta arg_ty | isUnliftedType arg_ty -> True
+ -- If we are coming from a beta-reduction (FromBeta) we must
+ -- establish the let-can-float invariant, so go via StrictBind
+ -- If not, the invariant holds already, and it's optional.
+ -- Using arg_ty: see Note [Dark corner with representation polymorphism]
+ -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg
+ -- When we come to `x=arg` we myst choose lazy/strict correctly
+ -- It's wrong to err in either directly
+
+ _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)
+
------------------
simplRecE :: SimplEnv
@@ -1835,7 +1869,7 @@ Note [Avoiding exponential behaviour]
One way in which we can get exponential behaviour is if we simplify a
big expression, and then re-simplify it -- and then this happens in a
deeply-nested way. So we must be jolly careful about re-simplifying
-an expression. That is why simplNonRecX does not try
+an expression (#13379). That is why simplNonRecX does not try
preInlineUnconditionally (unlike simplNonRecE).
Example:
@@ -2618,15 +2652,10 @@ Is this inefficient? Not really: we are about to walk over the result
of the rule firing to simplify it, so occurrence analysis is at most
a constant factor.
-Possible improvement: occ-anal the rules when putting them in the
-database; and in the simplifier just occ-anal the OutExpr arguments.
-But that's more complicated and the rule RHS is usually tiny; so I'm
-just doing the simple thing.
-
-Historical note: previously we did occ-anal the rules in Rule.hs,
-but failed to occ-anal the OutExpr arguments, which led to the
-nasty performance problem described above.
-
+Note, however, that the rule RHS is /already/ occ-analysed; see
+Note [OccInfo in unfoldings and rules] in GHC.Core. There is something
+unsatisfactory about doing it twice; but the rule RHS is usually very
+small, and this is simple.
Note [Optimising tagToEnum#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2930,7 +2959,7 @@ rebuildCase env scrut case_bndr alts cont
where
simple_rhs env wfloats case_bndr_rhs bs rhs =
assert (null bs) $
- do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs
+ do { (floats1, env') <- simplAuxBind env case_bndr case_bndr_rhs
-- scrut is a constructor application,
-- hence satisfies let-can-float invariant
; (floats2, expr') <- simplExprF env' rhs cont
@@ -2997,7 +3026,7 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont
| all_dead_bndrs
, doCaseToLet scrut case_bndr
= do { tick (CaseElim case_bndr)
- ; (floats1, env') <- simplNonRecX env case_bndr scrut
+ ; (floats1, env') <- simplAuxBind env case_bndr scrut
; (floats2, expr') <- simplExprF env' rhs cont
; return (floats1 `addFloats` floats2, expr') }
@@ -3483,12 +3512,11 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
bind_args env' (b:bs') (arg : args)
= assert (isId b) $
do { let b' = zap_occ b
- -- Note that the binder might be "dead", because it doesn't
- -- occur in the RHS; and simplNonRecX may therefore discard
- -- it via postInlineUnconditionally.
+ -- zap_occ: the binder might be "dead", because it doesn't
+ -- occur in the RHS; and simplAuxBind may therefore discard it.
-- Nevertheless we must keep it if the case-binder is alive,
-- because it may be used in the con_app. See Note [knownCon occ info]
- ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant
+ ; (floats1, env2) <- simplAuxBind env' b' arg -- arg satisfies let-can-float invariant
; (floats2, env3) <- bind_args env2 bs' args
; return (floats1 `addFloats` floats2, env3) }
@@ -3514,7 +3542,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
; let con_app = Var (dataConWorkId dc)
`mkTyApps` dc_ty_args
`mkApps` dc_args
- ; simplNonRecX env bndr con_app }
+ ; simplAuxBind env bndr con_app }
-------------------
missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
@@ -3621,15 +3649,15 @@ mkDupableContWithDmds env dmds (TickIt t cont)
; return (floats, TickIt t cont') }
mkDupableContWithDmds env _
- (StrictBind { sc_bndr = bndr, sc_body = body
+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
, sc_env = se, sc_cont = cont})
-- See Note [Duplicating StrictBind]
-- K[ let x = <> in b ] --> join j x = K[ b ]
-- j <>
= do { let sb_env = se `setInScopeFromE` env
; (sb_env1, bndr') <- simplBinder sb_env bndr
- ; (floats1, join_inner) <- simplLam sb_env1 body cont
- -- No need to use mkDupableCont before simplLam; we
+ ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont
+ -- No need to use mkDupableCont before simplNonRecBody; we
-- use cont once here, and then share the result if necessary
; let join_body = wrapFloats floats1 join_inner
@@ -3757,6 +3785,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty
, StrictBind { sc_bndr = arg_bndr
, sc_body = join_rhs
, sc_env = zapSubstEnv env
+ , sc_from = FromLet
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup
, sc_cont = mkBoringStop res_ty } )
@@ -4430,7 +4459,9 @@ simplRules env mb_new_id rules bind_cxt
; return (rule { ru_bndrs = bndrs'
, ru_fn = fn_name'
, ru_args = args'
- , ru_rhs = rhs' }) }
+ , ru_rhs = occurAnalyseExpr rhs' }) }
+ -- Remember to occ-analyse, to drop dead code.
+ -- See Note [OccInfo in unfoldings and rules] in GHC.Core
{- Note [Simplifying the RHS of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Core.Opt.Simplify.Utils (
BindContext(..), bindContextLevel,
-- The continuation type
- SimplCont(..), DupFlag(..), StaticEnv,
+ SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,
isSimplified, contIsStop,
contIsDupable, contResultType, contHoleType, contHoleScaling,
contIsTrivial, contArgs, contIsRhs,
@@ -192,6 +192,7 @@ data SimplCont
-- or, equivalently, = K[ (\x.b) e ]
{ sc_dup :: DupFlag -- See Note [DupFlag invariants]
, sc_bndr :: InId
+ , sc_from :: FromWhat
, sc_body :: InExpr
, sc_env :: StaticEnv -- See Note [StaticEnv invariant]
, sc_cont :: SimplCont }
@@ -213,6 +214,8 @@ data SimplCont
type StaticEnv = SimplEnv -- Just the static part is relevant
+data FromWhat = FromLet | FromBeta OutType
+
-- See Note [DupFlag invariants]
data DupFlag = NoDup -- Unsimplified, might be big
| Simplified -- Simplified
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.Core.Tidy ( tidyRules )
import GHC.Core.Map.Expr ( eqCoreExpr )
import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )
import GHC.Core.Make ( mkCoreLams )
+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr )
import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe )
import GHC.Builtin.Types ( anyTypeOfKind )
@@ -189,13 +190,18 @@ mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'GHC.Core.CoreRule'
mkRule this_mod is_auto is_local name act fn bndrs args rhs
- = Rule { ru_name = name, ru_fn = fn, ru_act = act,
- ru_bndrs = bndrs, ru_args = args,
- ru_rhs = rhs,
- ru_rough = roughTopNames args,
- ru_origin = this_mod,
- ru_orphan = orph,
- ru_auto = is_auto, ru_local = is_local }
+ = Rule { ru_name = name
+ , ru_act = act
+ , ru_fn = fn
+ , ru_bndrs = bndrs
+ , ru_args = args
+ , ru_rhs = occurAnalyseExpr rhs
+ -- See Note [OccInfo in unfoldings and rules]
+ , ru_rough = roughTopNames args
+ , ru_origin = this_mod
+ , ru_orphan = orph
+ , ru_auto = is_auto
+ , ru_local = is_local }
where
-- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv
-- A rule is an orphan only if none of the variables
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -513,8 +513,8 @@ bindNonRec bndr rhs body
-- | Tests whether we have to use a @case@ rather than @let@ binding for this
-- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant"
needsCaseBinding :: Type -> CoreExpr -> Bool
-needsCaseBinding ty rhs =
- mightBeUnliftedType ty && not (exprOkForSpeculation rhs)
+needsCaseBinding ty rhs
+ = mightBeUnliftedType ty && not (exprOkForSpeculation rhs)
-- Make a case expression instead of a let
-- These can arise either from the desugarer,
-- or from beta reductions: (\x.e) (x +# y)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -4939,6 +4939,7 @@ needSourceNotes dflags = debugLevel dflags > 0
-- LinkerInfo contains any extra options needed by the system linker.
data LinkerInfo
= GnuLD [Option]
+ | Mold [Option]
| GnuGold [Option]
| LlvmLLD [Option]
| DarwinLD [Option]
=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -129,7 +129,11 @@ module GHC.JS.Make
-- * Miscellaneous
-- $misc
, allocData, allocClsA
- , dataFieldName, dataFieldNames
+ , dataName
+ , clsName
+ , dataFieldName
+ , varName
+ , jsClosureCount
)
where
@@ -142,10 +146,8 @@ import Control.Arrow ((***))
import Data.Array
import qualified Data.Map as M
-import GHC.Utils.Outputable (Outputable (..))
import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Types.Unique.Map
@@ -642,30 +644,48 @@ dataFieldCache :: Array Int FastString
dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache])
nFieldCache :: Int
-nFieldCache = 16384
+nFieldCache = 255
+
+jsClosureCount :: Int
+jsClosureCount = 24
dataFieldName :: Int -> FastString
dataFieldName i
- | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i)
+ | i < 0 || i > nFieldCache = mkFastString ('d' : show i)
| otherwise = dataFieldCache ! i
-dataFieldNames :: [FastString]
-dataFieldNames = fmap dataFieldName [1..nFieldCache]
-
-
-- | Cache "h$dXXX" names
dataCache :: Array Int FastString
-dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024])
+dataCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$d"++) . show) [(0::Int)..jsClosureCount])
+
+dataName :: Int -> FastString
+dataName i
+ | i < 0 || i > nFieldCache = mkFastString ("h$d" ++ show i)
+ | otherwise = dataCache ! i
allocData :: Int -> JExpr
allocData i = toJExpr (TxtI (dataCache ! i))
-- | Cache "h$cXXX" names
clsCache :: Array Int FastString
-clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024])
+clsCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$c"++) . show) [(0::Int)..jsClosureCount])
+
+clsName :: Int -> FastString
+clsName i
+ | i < 0 || i > jsClosureCount = mkFastString ("h$c" ++ show i)
+ | otherwise = clsCache ! i
allocClsA :: Int -> JExpr
-allocClsA i = toJExpr (TxtI (clsCache ! i))
+allocClsA i = toJExpr (TxtI (clsName i))
+
+-- | Cache "xXXX" names
+varCache :: Array Int Ident
+varCache = listArray (0,jsClosureCount) (map (TxtI . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount])
+
+varName :: Int -> Ident
+varName i
+ | i < 0 || i > jsClosureCount = TxtI $ mkFastString ('x' : show i)
+ | otherwise = varCache ! i
--------------------------------------------------------------------------------
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -1006,7 +1006,7 @@ allocDynAll haveDecl middle cls = do
]
(ex:es) -> mconcat
[ toJExpr i .^ closureField1_ |= toJExpr ex
- , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es))
+ , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip (map dataFieldName [1..]) es))
]
| otherwise = case es of
[] -> mempty
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -81,36 +81,8 @@ resetResultVar r = toJExpr r |= null_
-- JIT can optimize better.
closureConstructors :: StgToJSConfig -> JStat
closureConstructors s = BlockStat
- [ declClsConstr "h$c" ["f"] $ Closure
- { clEntry = var "f"
- , clField1 = null_
- , clField2 = null_
- , clMeta = 0
- , clCC = ccVal
- }
- , declClsConstr "h$c0" ["f"] $ Closure
- { clEntry = var "f"
- , clField1 = null_
- , clField2 = null_
- , clMeta = 0
- , clCC = ccVal
- }
- , declClsConstr "h$c1" ["f", "x1"] $ Closure
- { clEntry = var "f"
- , clField1 = var "x1"
- , clField2 = null_
- , clMeta = 0
- , clCC = ccVal
- }
- , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure
- { clEntry = var "f"
- , clField1 = var "x1"
- , clField2 = var "x2"
- , clMeta = 0
- , clCC = ccVal
- }
- , mconcat (map mkClosureCon [3..24])
- , mconcat (map mkDataFill [1..24])
+ [ mconcat (map mkClosureCon (Nothing : map Just [0..jsClosureCount]))
+ , mconcat (map mkDataFill [1..jsClosureCount])
]
where
prof = csProf s
@@ -118,19 +90,8 @@ closureConstructors s = BlockStat
-- the cc argument happens to be named just like the cc field...
| prof = ([TxtI closureCC_], Just (var closureCC_))
| otherwise = ([], Nothing)
- addCCArg as = map TxtI as ++ ccArg
addCCArg' as = as ++ ccArg
- declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as)
- ( jVar $ \x ->
- [ checkC
- , x |= newClosure cl
- , notifyAlloc x
- , traceAlloc x
- , returnS x
- ]
- ))
-
traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x]
| otherwise = mempty
@@ -172,26 +133,36 @@ closureConstructors s = BlockStat
| otherwise = mempty
- mkClosureCon :: Int -> JStat
- mkClosureCon n = funName ||= toJExpr fun
+ mkClosureCon :: Maybe Int -> JStat
+ mkClosureCon n0 = funName ||= toJExpr fun
where
- funName = TxtI $ mkFastString ("h$c" ++ show n)
+ n | Just n' <- n0 = n'
+ | Nothing <- n0 = 0
+ funName | Just n' <- n0 = TxtI $ clsName n'
+ | Nothing <- n0 = TxtI $ mkFastString "h$c"
-- args are: f x1 x2 .. xn [cc]
- args = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n])
+ args = TxtI "f" : addCCArg' (map varName [1..n])
fun = JFunc args funBod
-- x1 goes into closureField1. All the other args are bundled into an
-- object in closureField2: { d1 = x2, d2 = x3, ... }
--
- extra_args = ValExpr . JHash . listToUniqMap $ zip
- (map (mkFastString . ('d':) . show) [(1::Int)..])
- (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n])
+ vars = map (toJExpr . varName) [1..n]
+
+ x1 = case vars of
+ [] -> null_
+ x:_ -> x
+ x2 = case vars of
+ [] -> null_
+ [_] -> null_
+ [_,x] -> x
+ _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (map dataFieldName [1..]) (x:xs)
funBod = jVar $ \x ->
[ checkC
, x |= newClosure Closure
{ clEntry = var "f"
- , clField1 = var "x1"
- , clField2 = extra_args
+ , clField1 = x1
+ , clField2 = x2
, clMeta = 0
, clCC = ccVal
}
@@ -203,8 +174,8 @@ closureConstructors s = BlockStat
mkDataFill :: Int -> JStat
mkDataFill n = funName ||= toJExpr fun
where
- funName = TxtI $ mkFastString ("h$d" ++ show n)
- ds = map (mkFastString . ('d':) . show) [(1::Int)..n]
+ funName = TxtI $ dataName n
+ ds = map dataFieldName [1..n]
extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds
fun = JFunc (map TxtI ds) (checkD <> returnS extra_args)
@@ -215,7 +186,7 @@ stackManip = mconcat (map mkPush [1..32]) <>
where
mkPush :: Int -> JStat
mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n)
- as = map (TxtI . mkFastString . ('x':) . show) [1..n]
+ as = map varName [1..n]
fun = JFunc as ((sp |= sp + toJExpr n)
<> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a)
[1..] as))
@@ -228,7 +199,7 @@ stackManip = mconcat (map mkPush [1..32]) <>
bits = bitsIdx sig
n = length bits
h = last bits
- args = map (TxtI . mkFastString . ('x':) . show) [1..n]
+ args = map varName [1..n]
fun = JFunc args $
mconcat [ sp |= sp + toJExpr (h+1)
, mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args)
@@ -288,7 +259,7 @@ loadRegs :: JStat
loadRegs = mconcat $ map mkLoad [1..32]
where
mkLoad :: Int -> JStat
- mkLoad n = let args = map (TxtI . mkFastString . ("x"++) . show) [1..n]
+ mkLoad n = let args = map varName [1..n]
assign = zipWith (\a r -> toJExpr r |= toJExpr a)
args (reverse $ take n regsFromR1)
fname = TxtI $ mkFastString ("h$l" ++ show n)
=====================================
compiler/GHC/SysTools/Info.hs
=====================================
@@ -70,6 +70,7 @@ The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
neededLinkArgs :: LinkerInfo -> [Option]
neededLinkArgs (GnuLD o) = o
+neededLinkArgs (Mold o) = o
neededLinkArgs (GnuGold o) = o
neededLinkArgs (LlvmLLD o) = o
neededLinkArgs (DarwinLD o) = o
@@ -106,6 +107,10 @@ getLinkerInfo' logger dflags = do
-- see Note [ELF needed shared libs]
"-Wl,--no-as-needed"])
+ | any ("mold" `isPrefixOf`) stdo =
+ return (Mold $ map Option [ --see Note [ELF needed shared libs]
+ "-Wl,--no-as-needed"])
+
| any ("GNU gold" `isPrefixOf`) stdo =
-- GNU gold only needs --no-as-needed. #10110.
-- ELF specific flag, see Note [ELF needed shared libs]
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -723,12 +723,14 @@ setIdCprSig id sig = modifyIdInfo (\info -> setCprSigInfo info sig) id
zapIdDmdSig :: Id -> Id
zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id
--- | This predicate says whether the 'Id' has a strict demand placed on it or
--- has a type such that it can always be evaluated strictly (i.e an
--- unlifted type, as of GHC 7.6). We need to
--- check separately whether the 'Id' has a so-called \"strict type\" because if
--- the demand for the given @id@ hasn't been computed yet but @id@ has a strict
--- type, we still want @isStrictId id@ to be @True at .
+-- | `isStrictId` says whether either
+-- (a) the 'Id' has a strict demand placed on it or
+-- (b) definitely has a \"strict type\", such that it can always be
+-- evaluated strictly (i.e an unlifted type)
+-- We need to check (b) as well as (a), because when the demand for the
+-- given `id` hasn't been computed yet but `id` has a strict
+-- type, we still want `isStrictId id` to be `True`.
+-- Returns False if the type is levity polymorphic; False is always safe.
isStrictId :: Id -> Bool
isStrictId id
| assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
module GHC.Unit.Module.ModIface
( ModIface
@@ -549,20 +550,58 @@ emptyIfaceHashCache _occ = Nothing
-- Take care, this instance only forces to the degree necessary to
-- avoid major space leaks.
-instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where
- rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12
- f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =
- rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`
- f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq`
- rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` rnf f21 `seq` f22 `seq` f23 `seq` rnf f24
+instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
+ , NFData (IfaceDeclExts (phase :: ModIfacePhase))
+ ) => NFData (ModIface_ phase) where
+ rnf (ModIface{ mi_module, mi_sig_of, mi_hsc_src, mi_deps, mi_usages
+ , mi_exports, mi_used_th, mi_fixities, mi_warns, mi_anns
+ , mi_decls, mi_extra_decls, mi_globals, mi_insts
+ , mi_fam_insts, mi_rules, mi_hpc, mi_trust, mi_trust_pkg
+ , mi_complete_matches, mi_docs, mi_final_exts
+ , mi_ext_fields, mi_src_hash})
+ = rnf mi_module
+ `seq` rnf mi_sig_of
+ `seq` mi_hsc_src
+ `seq` mi_deps
+ `seq` mi_usages
+ `seq` mi_exports
+ `seq` rnf mi_used_th
+ `seq` mi_fixities
+ `seq` mi_warns
+ `seq` rnf mi_anns
+ `seq` rnf mi_decls
+ `seq` rnf mi_extra_decls
+ `seq` mi_globals
+ `seq` rnf mi_insts
+ `seq` rnf mi_fam_insts
+ `seq` rnf mi_rules
+ `seq` rnf mi_hpc
+ `seq` mi_trust
+ `seq` rnf mi_trust_pkg
+ `seq` rnf mi_complete_matches
+ `seq` rnf mi_docs
+ `seq` mi_final_exts
+ `seq` mi_ext_fields
+ `seq` rnf mi_src_hash
`seq` ()
-
instance NFData (ModIfaceBackend) where
- rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)
- = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq`
- rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq`
- rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` rnf f13
+ rnf (ModIfaceBackend{ mi_iface_hash, mi_mod_hash, mi_flag_hash, mi_opt_hash
+ , mi_hpc_hash, mi_plugin_hash, mi_orphan, mi_finsts, mi_exp_hash
+ , mi_orphan_hash, mi_warn_fn, mi_fix_fn, mi_hash_fn})
+ = rnf mi_iface_hash
+ `seq` rnf mi_mod_hash
+ `seq` rnf mi_flag_hash
+ `seq` rnf mi_opt_hash
+ `seq` rnf mi_hpc_hash
+ `seq` rnf mi_plugin_hash
+ `seq` rnf mi_orphan
+ `seq` rnf mi_finsts
+ `seq` rnf mi_exp_hash
+ `seq` rnf mi_orphan_hash
+ `seq` rnf mi_warn_fn
+ `seq` rnf mi_fix_fn
+ `seq` rnf mi_hash_fn
forceModIface :: ModIface -> IO ()
=====================================
libraries/base/Data/OldList.hs
=====================================
@@ -1511,7 +1511,7 @@ sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f =
map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
--- | Produce singleton list.
+-- | Construct a list from a single element.
--
-- >>> singleton True
-- [True]
=====================================
libraries/base/tests/all.T
=====================================
@@ -79,7 +79,9 @@ test('length001',
# excessive amounts of stack space. So we specifically set a low
# stack limit and mark it as failing under a few conditions.
[extra_run_opts('+RTS -K8m -RTS'),
- expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc'])],
+ expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']),
+ # JS doesn't support stack limit so the test sometimes passes just fine. We decrease the timeout duration to force the failure.
+ when(js_arch(), run_timeout_multiplier(0.2))],
compile_and_run, [''])
test('ratio001', normal, compile_and_run, [''])
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -31,6 +31,7 @@ module Language.Haskell.TH.Syntax
-- $infix
) where
+import qualified Data.Fixed as Fixed
import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
@@ -1056,6 +1057,15 @@ instance Lift Natural where
liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
+instance Lift (Fixed.Fixed a) where
+ liftTyped x = unsafeCodeCoerce (lift x)
+ lift (Fixed.MkFixed x) = do
+ ex <- lift x
+ return (ConE mkFixedName `AppE` ex)
+ where
+ mkFixedName =
+ mkNameG DataName "base" "Data.Fixed" "MkFixed"
+
instance Integral a => Lift (Ratio a) where
liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -7,6 +7,7 @@
* Add `TypeDataD` constructor to the `Dec` type for `type data`
declarations (GHC proposal #106).
+ * Add `instance Lift (Fixed a)`
## 2.19.0.0
=====================================
libraries/transformers
=====================================
@@ -1 +1 @@
-Subproject commit ceff1dcd7893f7ab4abb6e66bcd248abd86c8886
+Subproject commit ef4fa181ebea77ac6997d392d1ef5a09524f06b2
=====================================
testsuite/driver/testlib.py
=====================================
@@ -129,14 +129,17 @@ def no_deps( name, opts):
def skip( name, opts ):
opts.skip = True
+def js_arch() -> bool:
+ return arch("javascript");
+
# disable test on JS arch
def js_skip( name, opts ):
- if arch("javascript"):
+ if js_arch():
skip(name,opts)
# expect broken for the JS backend
def js_broken( bug: IssueNumber ):
- if arch("javascript"):
+ if js_arch():
return expect_broken(bug);
else:
return normal;
=====================================
testsuite/tests/driver/T1959/test.T
=====================================
@@ -1 +1 @@
-test('T1959', [extra_files(['B.hs', 'C.hs', 'D.hs', 'E1.hs', 'E2.hs']), js_broken(22261)], makefile_test, ['dotest'])
+test('T1959', [extra_files(['B.hs', 'C.hs', 'D.hs', 'E1.hs', 'E2.hs']), js_broken(22374)], makefile_test, ['dotest'])
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -167,10 +167,10 @@ test('T5594', [ omit_ways(['ghci']),
],
compile_and_run, ['T5594_c.c -no-hs-main'])
-test('Capi_Ctype_001', [extra_files(['Capi_Ctype_A_001.hsc', 'capi_ctype_001.h', 'capi_ctype_001_c.c']), js_broken(22374)],
+test('Capi_Ctype_001', [extra_files(['Capi_Ctype_A_001.hsc', 'capi_ctype_001.h', 'capi_ctype_001_c.c']), req_c],
makefile_test, ['Capi_Ctype_001'])
-test('Capi_Ctype_002', [extra_files(['Capi_Ctype_A_002.hsc', 'capi_ctype_002_A.h', 'capi_ctype_002_B.h']), js_broken(22374)],
+test('Capi_Ctype_002', [extra_files(['Capi_Ctype_A_002.hsc', 'capi_ctype_002_A.h', 'capi_ctype_002_B.h']), req_c],
makefile_test, ['Capi_Ctype_002'])
test('ffi_parsing_001', [omit_ways(['ghci']), req_c], compile_and_run,
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -258,7 +258,7 @@ test('T6006', [ omit_ways(prof_ways + ['ghci']),
# needs it.
compile_and_run, ['T6006_c.c -no-hs-main'])
-test('T7037', js_broken(22374), makefile_test, ['T7037'])
+test('T7037', req_c, makefile_test, ['T7037'])
test('T7087', exit_code(1), compile_and_run, [''])
test('T7160', [ omit_ways(['nonmoving_thr', 'nonmoving_thr_ghc'])
=====================================
testsuite/tests/safeHaskell/check/pkg01/all.T
=====================================
@@ -32,7 +32,7 @@ test('safePkg01',
normalise_version("array", "ghc-bignum", "bytestring",
"base", "deepseq", "ghc-prim"),
normalise_fun(normalise_errmsg),
- js_skip],
+ js_broken(22356)],
run_command, ['$MAKE -s --no-print-directory safePkg01 ' + make_args])
# Fail since we enable package trust
=====================================
testsuite/tests/simplCore/should_compile/T22761.hs
=====================================
@@ -0,0 +1,40 @@
+module T22761 where
+
+import T22761a
+
+newtype Mod m = Mod m deriving Num
+
+gcdExt :: Integer -> (Integer, Integer)
+gcdExt x = go 0 x
+ where
+ go !_ 0 = (1, 1)
+ go r _ = go r r
+
+pow :: (Num m) => Mod m -> Mod m
+pow x = x*x*x
+{-# NOINLINE [1] pow #-}
+{-# RULES
+"powMod/3/Int" forall x. pow x = x*x*x
+#-}
+
+
+-- GHC puts `boo1` after `wom1` (since they don't appear connected)
+-- Then { wom1 = foo True } rewrites to { wom1 = boo False }
+-- so we need to do glomming. And that triggers the bug
+-- in the RULE for `pow`!
+--
+-- wom2/boo2 are there to still elicit the bug if
+-- GHC reverses its default ordering
+
+{-# RULES
+"wombat1" foo True = boo1 False
+#-}
+
+wom1 = foo True
+boo1 x = x
+
+{-# RULES
+"wombat2" foo True = boo2 False
+#-}
+boo2 x = x
+wom2 = foo True
=====================================
testsuite/tests/simplCore/should_compile/T22761a.hs
=====================================
@@ -0,0 +1,4 @@
+module T22761a where
+
+{-# NOINLINE [0] foo #-}
+foo x = x
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -152,7 +152,7 @@ test('T7702',
# allocation done by the plugin... but a regression allocates > 90mb
collect_compiler_stats('peak_megabytes_allocated',70),
when(opsys('mingw32'), fragile_for(16799, ['normal'])),
- js_skip
+ req_interp
],
compile,
['-v0 -package-db T7702plugin/pkg.T7702/local.package.conf -fplugin T7702Plugin -package T7702plugin ' + config.plugin_way_flags])
@@ -471,5 +471,6 @@ test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile,
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
test('T22802', normal, compile, ['-O'])
test('T15205', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T22761', normal, multimod_compile, ['T22761', '-O2 -v0'])
test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70ef6b07d4adfc62b7d2cac4c7bc6a46b684490e...c0791ba37eeddd40b2935a9d8bf8a61dc0111728
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70ef6b07d4adfc62b7d2cac4c7bc6a46b684490e...c0791ba37eeddd40b2935a9d8bf8a61dc0111728
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/20230212/6dd601b5/attachment-0001.html>
More information about the ghc-commits
mailing list