[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: testsuite: Add test for #21583
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Aug 18 23:09:09 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
714c936f by Bryan Richter at 2022-08-18T18:37:21-04:00
testsuite: Add test for #21583
- - - - -
989b844d by Ben Gamari at 2022-08-18T18:37:57-04:00
compiler: Drop --build-id=none hack
Since 2011 the object-joining implementation has had a hack to pass
`--build-id=none` to `ld` when supported, seemingly to work around a
linker bug. This hack is now unnecessary and may break downstream users
who expect objects to have valid build-ids. Remove it.
Closes #22060.
- - - - -
55e7c11b by Matthew Pickering at 2022-08-18T19:08:45-04:00
Make ru_fn field strict to avoid retaining Ids
It's better to perform this projection from Id to Name strictly so we
don't retain an old Id (hence IdInfo, hence Unfolding, hence everything
etc)
- - - - -
6c555da7 by Matthew Pickering at 2022-08-18T19:08:45-04:00
Force `getOccFS bndr` to avoid retaining reference to Bndr.
This is another symptom of #19619
- - - - -
2797960e by Matthew Pickering at 2022-08-18T19:08:45-04:00
Force unfoldings when they are cleaned-up in Tidy and CorePrep
If these thunks are not forced then the entire unfolding for the binding
is live throughout the whole of CodeGen despite the fact it should have
been discarded.
Fixes #22071
- - - - -
666ef374 by Matthew Pickering at 2022-08-18T19:08:46-04:00
haddock docs: Fix links from identifiers to dependent packages
When implementing the base_url changes I made the pretty bad mistake of
zipping together two lists which were in different orders. The simpler
thing to do is just modify `haddockDependencies` to also return the
package identifier so that everything stays in sync.
Fixes #22001
- - - - -
021b1184 by Matthew Pickering at 2022-08-18T19:08:47-04:00
Revert "Refactor SpecConstr to use treat bindings uniformly"
This reverts commit 415468fef8a3e9181b7eca86de0e05c0cce31729.
This refactoring introduced quite a severe residency regression (900MB
live from 650MB live when compiling mmark), see #21993 for a reproducer
and more discussion.
Ticket #21993
- - - - -
20 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- hadrian/bindist/Makefile
- hadrian/cfg/system.config.in
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/Haddock.hs
- − m4/fp_prog_ld_build_id.m4
- mk/config.mk.in
- rts/include/ghc.mk
- + testsuite/tests/typecheck/should_fail/T21583.hs
- + testsuite/tests/typecheck/should_fail/T21583.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1151,7 +1151,7 @@ data CoreRule
-- Rough-matching stuff
-- see comments with InstEnv.ClsInst( is_cls, is_rough )
- ru_fn :: Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule
+ ru_fn :: !Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule
ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side
-- Proper-matching stuff
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -634,7 +634,8 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
floats' = floats `extendFloats` NonRec bndr' triv_rhs
; return ( floats', setInScopeFromF env floats' ) } }
where
- occ_fs = getOccFS bndr
+ -- Force the occ_fs so that the old Id is not retained in the new Id.
+ !occ_fs = getOccFS bndr
uf_opts = seUnfoldingOpts env
work_ty = coercionLKind co
info = idInfo bndr
@@ -711,9 +712,11 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs
-- rhs_env: add to in-scope set the binders from rhs_floats
-- so that prepareRhs knows what is in scope in rhs
; let rhs_env = env `setInScopeFromF` rhs_floats1
+ -- Force the occ_fs so that the old Id is not retained in the new Id.
+ !occ_fs = getOccFS bndr
-- Now ANF-ise the remaining rhs
- ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1
+ ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1
-- Finally, decide whether or not to float
; let all_floats = rhs_floats1 `addLetFloats` anf_floats
@@ -4294,7 +4297,8 @@ simplRules env mb_new_id rules bind_cxt
lhs_env = updMode updModeForRules env'
rhs_env = updMode (updModeForStableUnfoldings act) env'
-- See Note [Simplifying the RHS of a RULE]
- fn_name' = case mb_new_id of
+ -- Force this to avoid retaining reference to old Id
+ !fn_name' = case mb_new_id of
Just id -> idName id
Nothing -> fn_name
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -77,7 +77,6 @@ import GHC.Serialized ( deserializeWithData )
import Control.Monad ( zipWithM )
import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
-import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
{-
@@ -375,14 +374,11 @@ The recursive call ends up looking like
So we want to spot the constructor application inside the cast.
That's why we have the Cast case in argToPat
-Note [Seeding recursive groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a recursive group that is either
- * nested, or
- * top-level, but with no exported Ids
-we can see all the calls to the function, so we seed the specialisation
-loop from the calls in the body, and /not/ from the calls in the RHS.
-Consider:
+Note [Local recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a *local* recursive group, we can see all the calls to the
+function, so we seed the specialisation loop from the calls in the
+body, not from the calls in the RHS. Consider:
bar m n = foo n (n,n) (n,n) (n,n) (n,n)
where
@@ -405,42 +401,52 @@ a local function.
In a case like the above we end up never calling the original un-specialised
function. (Although we still leave its code around just in case.)
-Wrinkles
-
-* Boring calls. If we find any boring calls in the body, including
- *unsaturated* ones, such as
+However, if we find any boring calls in the body, including *unsaturated*
+ones, such as
letrec foo x y = ....foo...
in map foo xs
- then we will end up calling the un-specialised function, so then we
- *should* use the calls in the un-specialised RHS as seeds. We call
- these "boring call patterns", and callsToNewPats reports if it finds
- any of these. Then 'specialise' unleashes the usage info from the
- un-specialised RHS.
-
-* Exported Ids. `specialise` /also/ unleashes `si_mb_unspec`
- for exported Ids. That way we are sure to generate usage info from
- the /un-specialised/ RHS of an exported function.
-
-More precisely:
-
-* Always start from the calls in the body of the let or (for top level)
- calls in the rest of the module. See the body_calls in the call to
- `specialise` in `specNonRec`, and to `go` in `specRec`.
-
-* si_mb_unspec holds the usage from the unspecialised RHS.
- See `initSpecInfo`.
-
-* `specialise` will unleash si_mb_unspec, if
- - `callsToNewPats` reports "boring calls found", or
- - this is a top-level exported Id.
-
-Historical note. At an earlier point, if a top-level Id was exported,
-we used only seeds from the RHS, and /not/from the body. But Dimitrios
-had an example where using call patterns from the body (the other defns
-in the module) was crucial. And doing so improved nofib allocation results:
- multiplier: 4% better
- minimax: 2.8% better
-In any case, it is easier to do!
+then we will end up calling the un-specialised function, so then we *should*
+use the calls in the un-specialised RHS as seeds. We call these
+"boring call patterns", and callsToPats reports if it finds any of these.
+
+Note [Seeding top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This seeding is done in the binding for seed_calls in specRec.
+
+1. If all the bindings in a top-level recursive group are local (not
+ exported), then all the calls are in the rest of the top-level
+ bindings. This means we can specialise with those call patterns
+ ONLY, and NOT with the RHSs of the recursive group (exactly like
+ Note [Local recursive groups])
+
+2. But if any of the bindings are exported, the function may be called
+ with any old arguments, so (for lack of anything better) we specialise
+ based on
+ (a) the call patterns in the RHS
+ (b) the call patterns in the rest of the top-level bindings
+ NB: before Apr 15 we used (a) only, but Dimitrios had an example
+ where (b) was crucial, so I added that.
+ Adding (b) also improved nofib allocation results:
+ multiplier: 4% better
+ minimax: 2.8% better
+
+Actually in case (2), instead of using the calls from the RHS, it
+would be better to specialise in the importing module. We'd need to
+add an INLINABLE pragma to the function, and then it can be
+specialised in the importing scope, just as is done for type classes
+in GHC.Core.Opt.Specialise.specImports. This remains to be done (#10346).
+
+Note [Top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To get the call usage information from "the rest of the top level
+bindings" (c.f. Note [Seeding top-level recursive groups]), we work
+backwards through the top-level bindings so we see the usage before we
+get to the binding of the function. Before we can collect the usage
+though, we go through all the bindings and add them to the
+environment. This is necessary because usage is only tracked for
+functions in the environment. These two passes are called
+ 'go' and 'goEnv'
+in specConstrProgram. (Looks a bit revolting to me.)
Note [Do not specialise diverging functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -758,18 +764,35 @@ unbox the strict fields, because T is polymorphic!)
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram guts
- = do { env0 <- initScEnv guts
- ; us <- getUniqueSupplyM
- ; let (_usg, binds') = initUs_ us $
- scTopBinds env0 (mg_binds guts)
-
- ; return (guts { mg_binds = binds' }) }
-
-scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind])
-scTopBinds _env [] = return (nullUsage, [])
-scTopBinds env (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $
- (\env -> scTopBinds env bs)
- ; return (usg, b' ++ bs') }
+ = do
+ dflags <- getDynFlags
+ us <- getUniqueSupplyM
+ (_, annos) <- getFirstAnnotations deserializeWithData guts
+ this_mod <- getModule
+ -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)
+ let binds' = reverse $ fst $ initUs us $ do
+ -- Note [Top-level recursive groups]
+ (env, binds) <- goEnv (initScEnv (initScOpts dflags this_mod) annos)
+ (mg_binds guts)
+ -- binds is identical to (mg_binds guts), except that the
+ -- binders on the LHS have been replaced by extendBndr
+ -- (SPJ this seems like overkill; I don't think the binders
+ -- will change at all; and we don't substitute in the RHSs anyway!!)
+ go env nullUsage (reverse binds)
+
+ return (guts { mg_binds = binds' })
+ where
+ -- See Note [Top-level recursive groups]
+ goEnv env [] = return (env, [])
+ goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind
+ (env'', binds') <- goEnv env' binds
+ return (env'', bind' : binds')
+
+ -- Arg list of bindings is in reverse order
+ go _ _ [] = return []
+ go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind
+ binds' <- go env usg' binds
+ return (bind' : binds')
{-
************************************************************************
@@ -933,24 +956,14 @@ initScOpts dflags this_mod = SpecConstrOpts
sc_keen = gopt Opt_SpecConstrKeen dflags
}
-initScEnv :: ModGuts -> CoreM ScEnv
-initScEnv guts
- = do { dflags <- getDynFlags
- ; (_, anns) <- getFirstAnnotations deserializeWithData guts
- ; this_mod <- getModule
- ; return (SCE { sc_opts = initScOpts dflags this_mod,
- sc_force = False,
- sc_subst = init_subst,
- sc_how_bound = emptyVarEnv,
- sc_vals = emptyVarEnv,
- sc_annotations = anns }) }
- where
- init_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $
- bindersOfBinds (mg_binds guts)
- -- Acccount for top-level bindings that are not in dependency order;
- -- see Note [Glomming] in GHC.Core.Opt.OccurAnal
- -- Easiest thing is to bring all the top level binders into scope at once,
- -- as if at once, as if all the top-level decls were mutually recursive.
+initScEnv :: SpecConstrOpts -> UniqFM Name SpecConstrAnnotation -> ScEnv
+initScEnv opts anns
+ = SCE { sc_opts = opts,
+ sc_force = False,
+ sc_subst = emptySubst,
+ sc_how_bound = emptyVarEnv,
+ sc_vals = emptyVarEnv,
+ sc_annotations = anns }
data HowBound = RecFun -- These are the recursive functions for which
-- we seek interesting call patterns
@@ -1174,8 +1187,8 @@ data ScUsage
scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
} -- The domain is OutIds
-type CallEnv = IdEnv [Call] -- Domain is OutIds
-data Call = Call OutId [CoreArg] ValueEnv
+type CallEnv = IdEnv [Call]
+data Call = Call Id [CoreArg] ValueEnv
-- The arguments of the call, together with the
-- env giving the constructor bindings at the call site
-- We keep the function mainly for debug output
@@ -1197,9 +1210,6 @@ nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls = plusVarEnv_C (++)
-delCallsFor :: ScUsage -> [Var] -> ScUsage
-delCallsFor env bndrs = env { scu_calls = scu_calls env `delVarEnvList` bndrs }
-
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
@@ -1282,121 +1292,6 @@ The main recursive function gathers up usage information, and
creates specialised versions of functions.
-}
-scBind :: TopLevelFlag -> ScEnv -> InBind
- -> (ScEnv -> UniqSM (ScUsage, a)) -- Specialise the scope of the binding
- -> UniqSM (ScUsage, [OutBind], a)
-scBind top_lvl env (NonRec bndr rhs) do_body
- | isTyVar bndr -- Type-lets may be created by doBeta
- = do { (final_usage, body') <- do_body (extendScSubst env bndr rhs)
- ; return (final_usage, [], body') }
-
- | not (isTopLevel top_lvl) -- Nested non-recursive value binding
- -- See Note [Specialising local let bindings]
- = do { let (body_env, bndr') = extendBndr env bndr
- -- Not necessary at top level; but here we are nested
-
- ; rhs_info <- scRecRhs env (bndr',rhs)
-
- ; let body_env2 = extendHowBound body_env [bndr'] RecFun
- rhs' = ri_new_rhs rhs_info
- body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
-
- ; (body_usg, body') <- do_body body_env3
-
- -- Now make specialised copies of the binding,
- -- based on calls in body_usg
- ; (spec_usg, specs) <- specNonRec env (scu_calls body_usg) rhs_info
- -- NB: For non-recursive bindings we inherit sc_force flag from
- -- the parent function (see Note [Forcing specialisation])
-
- -- Specialized + original binding
- ; let spec_bnds = [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs]
- bind_usage = (body_usg `delCallsFor` [bndr'])
- `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg]
-
- ; return (bind_usage, spec_bnds, body')
- }
-
- | otherwise -- Top-level, non-recursive value binding
- -- At top level we do not specialise non-recursive bindings; that
- -- is, we do not call specNonRec, passing the calls from the body.
- -- The original paper only specialised /recursive/ bindings, but
- -- we later started specialising nested non-recursive bindings:
- -- see Note [Specialising local let bindings]
- --
- -- I tried always specialising non-recursive top-level bindings too,
- -- but found some regressions (see !8135). So I backed off.
- = do { (rhs_usage, rhs') <- scExpr env rhs
-
- -- At top level, we've already put all binders into scope; see initScEnv
- -- Hence no need to call `extendBndr`. But we still want to
- -- extend the `ValueEnv` to record the value of this binder.
- ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs')
- ; (body_usage, body') <- do_body body_env
-
- ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') }
-
-scBind top_lvl env (Rec prs) do_body
- | isTopLevel top_lvl
- , Just threshold <- sc_size (sc_opts env)
- , not force_spec
- , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss)
- = -- Do no specialisation if the RHSs are too big
- -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor
- -- why it only applies at top level. But that's the way it has been
- -- for a while. See #21456.
- do { (body_usg, body') <- do_body rhs_env2
- ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss
- ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)
- `delCallsFor` bndrs'
- bind' = Rec (bndrs' `zip` rhss')
- ; return (all_usg, [bind'], body') }
-
- | otherwise
- = do { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
- ; (body_usg, body') <- do_body rhs_env2
-
- ; (spec_usg, specs) <- specRec (scForce rhs_env2 force_spec)
- (scu_calls body_usg) rhs_infos
- -- Do not unconditionally generate specialisations from rhs_usgs
- -- Instead use them only if we find an unspecialised call
- -- See Note [Seeding recursive groups]
-
- ; let all_usg = (spec_usg `combineUsage` body_usg) -- Note [spec_usg includes rhs_usg]
- `delCallsFor` bndrs'
- bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))
- -- zipWithEqual: length of returned [SpecInfo]
- -- should be the same as incoming [RhsInfo]
-
- ; return (all_usg, [bind'], body') }
- where
- (bndrs,rhss) = unzip prs
- force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation]
-
- (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs)
- | otherwise = extendRecBndrs env bndrs
- -- At top level, we've already put all binders into scope; see initScEnv
-
- rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
-
-{- Note [Specialising local let bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is not uncommon to find this
-
- let $j = \x. <blah> in ...$j True...$j True...
-
-Here $j is an arbitrary let-bound function, but it often comes up for
-join points. We might like to specialise $j for its call patterns.
-Notice the difference from a letrec, where we look for call patterns
-in the *RHS* of the function. Here we look for call patterns in the
-*body* of the let.
-
-At one point I predicated this on the RHS mentioning the outer
-recursive function, but that's not essential and might even be
-harmful. I'm not sure.
--}
-
-------------------------
scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
-- The unique supply is needed when we invent
-- a new name for the specialised function and its args
@@ -1421,11 +1316,6 @@ scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
(usg, e') <- scExpr env' e
return (usg, Lam b' e')
-scExpr' env (Let bind body)
- = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $
- (\env -> scExpr env body)
- ; return (final_usage, mkLets binds' body') }
-
scExpr' env (Case scrut b ty alts)
= do { (scrut_usg, scrut') <- scExpr env scrut
; case isValue (sc_vals env) scrut' of
@@ -1465,7 +1355,79 @@ scExpr' env (Case scrut b ty alts)
_ -> evalScrutOcc
; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
+scExpr' env (Let (NonRec bndr rhs) body)
+ | isTyVar bndr -- Type-lets may be created by doBeta
+ = scExpr' (extendScSubst env bndr rhs) body
+
+ | otherwise
+ = do { let (body_env, bndr') = extendBndr env bndr
+ ; rhs_info <- scRecRhs env (bndr',rhs)
+
+ ; let body_env2 = extendHowBound body_env [bndr'] RecFun
+ -- See Note [Local let bindings]
+ rhs' = ri_new_rhs rhs_info
+ body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
+
+ ; (body_usg, body') <- scExpr body_env3 body
+
+ -- NB: For non-recursive bindings we inherit sc_force flag from
+ -- the parent function (see Note [Forcing specialisation])
+ ; (spec_usg, specs) <- specNonRec env body_usg rhs_info
+
+ -- Specialized + original binding
+ ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body'
+ -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds)
+
+ ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
+ `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg]
+ spec_bnds
+ )
+ }
+
+
+-- A *local* recursive group: see Note [Local recursive groups]
+scExpr' env (Let (Rec prs) body)
+ = do { let (bndrs,rhss) = unzip prs
+ (rhs_env1,bndrs') = extendRecBndrs env bndrs
+ rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
+ force_spec = any (forceSpecBndr env) bndrs'
+ -- Note [Forcing specialisation]
+
+ ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
+ ; (body_usg, body') <- scExpr rhs_env2 body
+
+ -- NB: start specLoop from body_usg
+ ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)
+ body_usg rhs_infos
+ -- Do not unconditionally generate specialisations from rhs_usgs
+ -- Instead use them only if we find an unspecialised call
+ -- See Note [Local recursive groups]
+
+ ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg]
+ bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))
+ -- zipWithEqual: length of returned [SpecInfo]
+ -- should be the same as incoming [RhsInfo]
+
+ ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
+ Let bind' body') }
+
+{-
+Note [Local let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is not uncommon to find this
+
+ let $j = \x. <blah> in ...$j True...$j True...
+Here $j is an arbitrary let-bound function, but it often comes up for
+join points. We might like to specialise $j for its call patterns.
+Notice the difference from a letrec, where we look for call patterns
+in the *RHS* of the function. Here we look for call patterns in the
+*body* of the let.
+
+At one point I predicated this on the RHS mentioning the outer
+recursive function, but that's not essential and might even be
+harmful. I'm not sure.
+-}
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
@@ -1520,6 +1482,51 @@ mkVarUsage env fn args
arg_occ | null args = UnkOcc
| otherwise = evalScrutOcc
+----------------------
+scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
+scTopBindEnv env (Rec prs)
+ = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
+ rhs_env2 = extendHowBound rhs_env1 bndrs RecFun
+
+ prs' = zip bndrs' rhss
+ ; return (rhs_env2, Rec prs') }
+ where
+ (bndrs,rhss) = unzip prs
+
+scTopBindEnv env (NonRec bndr rhs)
+ = do { let (env1, bndr') = extendBndr env bndr
+ env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)
+ ; return (env2, NonRec bndr' rhs) }
+
+----------------------
+scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
+
+scTopBind env body_usage (Rec prs)
+ | Just threshold <- sc_size $ sc_opts env
+ , not force_spec
+ , not (all (couldBeSmallEnoughToInline (sc_uf_opts $ sc_opts env) threshold) rhss)
+ -- No specialisation
+ = -- pprTrace "scTopBind: nospec" (ppr bndrs) $
+ do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss
+ ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }
+
+ | otherwise -- Do specialisation
+ = do { rhs_infos <- mapM (scRecRhs env) prs
+
+ ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)
+ body_usage rhs_infos
+
+ ; return (body_usage `combineUsage` spec_usage,
+ Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }
+ where
+ (bndrs,rhss) = unzip prs
+ force_spec = any (forceSpecBndr env) bndrs
+ -- Note [Forcing specialisation]
+
+scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions
+ = do { (rhs_usg', rhs') <- scExpr env rhs
+ ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }
+
----------------------
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
scRecRhs env (bndr,rhs)
@@ -1567,8 +1574,7 @@ data RhsInfo
}
data SpecInfo -- Info about specialisations for a particular Id
- = SI { si_specs :: [OneSpec] -- The specialisations we have
- -- generated for this function
+ = SI { si_specs :: [OneSpec] -- The specialisations we have generated
, si_n_specs :: Int -- Length of si_specs; used for numbering them
@@ -1579,7 +1585,7 @@ data SpecInfo -- Info about specialisations for a particular Id
-- RHS usage (which has not yet been
-- unleashed)
-- Nothing => we have
- -- See Note [Seeding recursive groups]
+ -- See Note [Local recursive groups]
-- See Note [spec_usg includes rhs_usg]
-- One specialisation: Rule plus definition
@@ -1589,62 +1595,57 @@ data OneSpec =
, os_id :: OutId -- Spec id
, os_rhs :: OutExpr } -- Spec rhs
-initSpecInfo :: RhsInfo -> SpecInfo
-initSpecInfo (RI { ri_rhs_usg = rhs_usg })
- = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Just rhs_usg }
- -- si_mb_unspec: add in rhs_usg if there are any boring calls,
- -- or if the bndr is exported
+noSpecInfo :: SpecInfo
+noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }
----------------------
specNonRec :: ScEnv
- -> CallEnv -- Calls in body
+ -> ScUsage -- Body usage
-> RhsInfo -- Structure info usage info for un-specialised RHS
-> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not)
-- plus details of specialisations
-specNonRec env body_calls rhs_info
- = specialise env body_calls rhs_info (initSpecInfo rhs_info)
+specNonRec env body_usg rhs_info
+ = specialise env (scu_calls body_usg) rhs_info
+ (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })
----------------------
-specRec :: ScEnv
- -> CallEnv -- Calls in body
+specRec :: TopLevelFlag -> ScEnv
+ -> ScUsage -- Body usage
-> [RhsInfo] -- Structure info and usage info for un-specialised RHSs
-> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not)
-- plus details of specialisations
-specRec env body_calls rhs_infos
- = go 1 body_calls nullUsage (map initSpecInfo rhs_infos)
- -- body_calls: see Note [Seeding recursive groups]
- -- NB: 'go' always calls 'specialise' once, which in turn unleashes
- -- si_mb_unspec if there are any boring calls in body_calls,
- -- or if any of the Id(s) are exported
+specRec top_lvl env body_usg rhs_infos
+ = go 1 seed_calls nullUsage init_spec_infos
where
opts = sc_opts env
+ (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups]
+ | isTopLevel top_lvl
+ , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs
+ = (all_calls, [noSpecInfo | _ <- rhs_infos])
+ | otherwise -- Seed from body only
+ = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }
+ | ri <- rhs_infos])
+
+ calls_in_body = scu_calls body_usg
+ calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos
+ all_calls = calls_in_rhss `combineCalls` calls_in_body
-- Loop, specialising, until you get no new specialisations
- go, go_again :: Int -- Which iteration of the "until no new specialisations"
- -- loop we are on; first iteration is 1
- -> CallEnv -- Seed calls
- -- Two accumulating parameters:
- -> ScUsage -- Usage from earlier specialisations
- -> [SpecInfo] -- Details of specialisations so far
- -> UniqSM (ScUsage, [SpecInfo])
+ go :: Int -- Which iteration of the "until no new specialisations"
+ -- loop we are on; first iteration is 1
+ -> CallEnv -- Seed calls
+ -- Two accumulating parameters:
+ -> ScUsage -- Usage from earlier specialisations
+ -> [SpecInfo] -- Details of specialisations so far
+ -> UniqSM (ScUsage, [SpecInfo])
go n_iter seed_calls usg_so_far spec_infos
- = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
- -- , text "iteration" <+> int n_iter
- -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
- -- ]) $
- do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
- ; let (extra_usg_s, all_spec_infos) = unzip specs_w_usg
- extra_usg = combineUsages extra_usg_s
- all_usg = usg_so_far `combineUsage` extra_usg
- new_calls = scu_calls extra_usg
- ; go_again n_iter new_calls all_usg all_spec_infos }
-
- -- go_again deals with termination
- go_again n_iter seed_calls usg_so_far spec_infos
| isEmptyVarEnv seed_calls
- = return (usg_so_far, spec_infos)
+ = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)
+ -- , ppr seed_calls
+ -- , ppr body_usg ]) $
+ return (usg_so_far, spec_infos)
-- Limit recursive specialisation
-- See Note [Limit recursive specialisation]
@@ -1653,20 +1654,26 @@ specRec env body_calls rhs_infos
-- If both of these are false, the sc_count
-- threshold will prevent non-termination
, any ((> the_limit) . si_n_specs) spec_infos
- = -- Give up on specialisation, but don't forget to include the rhs_usg
- -- for the unspecialised function, since it may now be called
- -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $
- let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos)
- in return (usg_so_far `combineUsage` rhs_usgs, spec_infos)
+ = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $
+ return (usg_so_far, spec_infos)
| otherwise
- = go (n_iter + 1) seed_calls usg_so_far spec_infos
+ = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
+ -- , text "iteration" <+> int n_iter
+ -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
+ -- ]) $
+ do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
+ ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg
+ extra_usg = combineUsages extra_usg_s
+ all_usg = usg_so_far `combineUsage` extra_usg
+ ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }
-- See Note [Limit recursive specialisation]
the_limit = case sc_count opts of
Nothing -> 10 -- Ugh!
Just max -> max
+
----------------------
specialise
:: ScEnv
@@ -1689,12 +1696,14 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
spec_info@(SI { si_specs = specs, si_n_specs = spec_count
, si_mb_unspec = mb_unspec })
| isDeadEndId fn -- Note [Do not specialise diverging functions]
- -- /and/ do not generate specialisation seeds from its RHS
+ -- and do not generate specialisation seeds from its RHS
= -- pprTrace "specialise bot" (ppr fn) $
return (nullUsage, spec_info)
| not (isNeverActive (idInlineActivation fn))
-- See Note [Transfer activation]
+ --
+ --
-- Don't specialise OPAQUE things, see Note [OPAQUE pragma].
-- Since OPAQUE things are always never-active (see
-- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for
@@ -1720,16 +1729,14 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
; let spec_usg = combineUsages spec_usgs
- unspec_rhs_needed = boring_call || isExportedId fn
-
-- If there were any boring calls among the seeds (= all_calls), then those
-- calls will call the un-specialised function. So we should use the seeds
-- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning
-- then in new_usg.
- (new_usg, mb_unspec') = case mb_unspec of
- Just rhs_usg | unspec_rhs_needed
- -> (spec_usg `combineUsage` rhs_usg, Nothing)
- _ -> (spec_usg, mb_unspec)
+ (new_usg, mb_unspec')
+ = case mb_unspec of
+ Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
+ _ -> (spec_usg, mb_unspec)
-- ; pprTrace "specialise return }"
-- (vcat [ ppr fn
@@ -1737,8 +1744,8 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
-- , text "new calls:" <+> ppr (scu_calls new_usg)]) $
-- return ()
- ; return (new_usg, SI { si_specs = new_specs ++ specs
- , si_n_specs = spec_count + n_pats
+ ; return (new_usg, SI { si_specs = new_specs ++ specs
+ , si_n_specs = spec_count + n_pats
, si_mb_unspec = mb_unspec' }) }
| otherwise -- No calls, inactive, or not a function
@@ -2020,8 +2027,7 @@ calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
Note [spec_usg includes rhs_usg]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In calls to 'specialise', the returned ScUsage must include the rhs_usg in
-the passed-in SpecInfo in si_mb_unspec, unless there are no calls at all to
-the function.
+the passed-in SpecInfo, unless there are no calls at all to the function.
The caller can, indeed must, assume this. They should not combine in rhs_usg
themselves, or they'll get rhs_usg twice -- and that can lead to an exponential
@@ -2239,11 +2245,9 @@ callsToNewPats :: ScEnv -> Id
-> SpecInfo
-> [ArgOcc] -> [Call]
-> UniqSM (Bool, [CallPat])
--- Result has no duplicate patterns,
--- nor ones mentioned in si_specs (hence "new" patterns)
--- Bool indicates that there was at least one boring pattern
--- The "New" in the name means "patterns that are not already covered
--- by an existing specialisation"
+ -- Result has no duplicate patterns,
+ -- nor ones mentioned in done_pats
+ -- Bool indicates that there was at least one boring pattern
callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
= do { mb_pats <- mapM (callToPats env bndr_occs) calls
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -2153,7 +2153,9 @@ cpCloneBndr env bndr
-- Drop (now-useless) rules/unfoldings
-- See Note [Drop unfoldings and rules]
-- and Note [Preserve evaluatedness] in GHC.Core.Tidy
- ; let unfolding' = trimUnfolding (realIdUnfolding bndr)
+ -- And force it.. otherwise the old unfolding is just retained.
+ -- See #22071
+ ; let !unfolding' = trimUnfolding (realIdUnfolding bndr)
-- Simplifier will set the Id's unfolding
bndr'' = bndr' `setIdUnfolding` unfolding'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -1184,17 +1184,10 @@ joinObjectFiles hsc_env o_files output_fn
let toolSettings' = toolSettings dflags
ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
- map GHC.SysTools.Option ld_build_id
- ++ [ GHC.SysTools.Option "-o",
+ [ GHC.SysTools.Option "-o",
GHC.SysTools.FileOption "" output_fn ]
++ args)
- -- suppress the generation of the .note.gnu.build-id section,
- -- which we don't need and sometimes causes ld to emit a
- -- warning:
- ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]
- | otherwise = []
-
if ldIsGnuLd
then do
script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript"
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -81,7 +81,6 @@ module GHC.Driver.Session (
sTopDir,
sGlobalPackageDatabasePath,
sLdSupportsCompactUnwind,
- sLdSupportsBuildId,
sLdSupportsFilelist,
sLdIsGnuLd,
sGccSupportsNoPie,
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1292,12 +1292,14 @@ tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unf
--------- Unfolding ------------
unf_info = realUnfoldingInfo idinfo
- unfold_info
+ -- Force this, otherwise the old unfolding is retained over code generation
+ -- See #22071
+ !unfold_info
| isCompulsoryUnfolding unf_info || show_unfold
= tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
| otherwise
= minimal_unfold_info
- minimal_unfold_info = trimUnfolding unf_info
+ !minimal_unfold_info = trimUnfolding unf_info
unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs
-- NB: do *not* expose the worker if show_unfold is off,
-- because that means this thing is a loop breaker or
=====================================
compiler/GHC/Settings.hs
=====================================
@@ -18,7 +18,6 @@ module GHC.Settings
, sTopDir
, sGlobalPackageDatabasePath
, sLdSupportsCompactUnwind
- , sLdSupportsBuildId
, sLdSupportsFilelist
, sLdIsGnuLd
, sGccSupportsNoPie
@@ -87,7 +86,6 @@ data Settings = Settings
-- platform-specific and platform-agnostic.
data ToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind :: Bool
- , toolSettings_ldSupportsBuildId :: Bool
, toolSettings_ldSupportsFilelist :: Bool
, toolSettings_ldIsGnuLd :: Bool
, toolSettings_ccSupportsNoPie :: Bool
@@ -189,8 +187,6 @@ sGlobalPackageDatabasePath = fileSettings_globalPackageDatabase . sFileSettings
sLdSupportsCompactUnwind :: Settings -> Bool
sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings
-sLdSupportsBuildId :: Settings -> Bool
-sLdSupportsBuildId = toolSettings_ldSupportsBuildId . sToolSettings
sLdSupportsFilelist :: Settings -> Bool
sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings
sLdIsGnuLd :: Settings -> Bool
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -94,7 +94,6 @@ initSettings top_dir = do
cc_args = words cc_args_str ++ unreg_cc_args
cxx_args = words cxx_args_str
ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
- ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
arSupportsDashL <- getBooleanSetting "ar supports -L"
@@ -163,7 +162,6 @@ initSettings top_dir = do
, sToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
- , toolSettings_ldSupportsBuildId = ldSupportsBuildId
, toolSettings_ldSupportsFilelist = ldSupportsFilelist
, toolSettings_ldIsGnuLd = ldIsGnuLd
, toolSettings_ccSupportsNoPie = gccSupportsNoPie
=====================================
hadrian/bindist/Makefile
=====================================
@@ -91,7 +91,6 @@ lib/settings :
@echo ',("ld command", "$(SettingsLdCommand)")' >> $@
@echo ',("ld flags", "$(SettingsLdFlags)")' >> $@
@echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@
- @echo ',("ld supports build-id", "$(LdHasBuildId)")' >> $@
@echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@
@echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@
@echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -136,7 +136,6 @@ conf-merge-objects-args-stage3 = @MergeObjsArgs@
gcc-extra-via-c-opts = @GccExtraViaCOpts@
ld-has-no-compact-unwind = @LdHasNoCompactUnwind@
-ld-has-build-id = @LdHasBuildId@
ld-has-filelist = @LdHasFilelist@
ld-is-gnu-ld = @LdIsGNULd@
ar-args = @ArArgs@
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -249,7 +249,7 @@ buildPackageDocumentation = do
vanillaSrcs <- hsSources context
let srcs = vanillaSrcs `union` generatedSrcs
- need $ srcs ++ haddocks
+ need $ srcs ++ (map snd haddocks)
-- Build Haddock documentation
-- TODO: Pass the correct way from Rules via Context.
@@ -364,8 +364,8 @@ buildManPage = do
copyFileUntracked (dir -/- "ghc.1") file
-- | Find the Haddock files for the dependencies of the current library.
-haddockDependencies :: Context -> Action [FilePath]
+haddockDependencies :: Context -> Action [(Package, FilePath)]
haddockDependencies context = do
depNames <- interpretInContext context (getContextData depNames)
- sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
+ sequence [ (,) <$> pure depPkg <*> (pkgHaddockFile $ vanillaContext Stage1 depPkg)
| Just depPkg <- map findPackageByName depNames, depPkg /= rts ]
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -311,7 +311,6 @@ generateSettings = do
, ("ld command", expr $ settingsFileSetting SettingsFileSetting_LdCommand)
, ("ld flags", expr $ settingsFileSetting SettingsFileSetting_LdFlags)
, ("ld supports compact unwind", expr $ lookupSystemConfig "ld-has-no-compact-unwind")
- , ("ld supports build-id", expr $ lookupSystemConfig "ld-has-build-id")
, ("ld supports filelist", expr $ lookupSystemConfig "ld-has-filelist")
, ("ld is GNU ld", expr $ lookupSystemConfig "ld-is-gnu-ld")
, ("Merge objects command", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsCommand)
=====================================
hadrian/src/Settings/Builders/Haddock.hs
=====================================
@@ -43,9 +43,8 @@ haddockBuilderArgs = mconcat
context <- getContext
version <- expr $ pkgVersion pkg
synopsis <- expr $ pkgSynopsis pkg
- trans_deps <- expr $ contextDependencies context
- pkgs <- expr $ mapM (pkgIdentifier . C.package) $ trans_deps
haddocks <- expr $ haddockDependencies context
+ haddocks_with_versions <- expr $ sequence $ [(,h) <$> pkgIdentifier p | (p, h) <- haddocks]
hVersion <- expr $ pkgVersion haddock
statsDir <- expr $ haddockStatsFilesDir
baseUrlTemplate <- expr (docsBaseUrl <$> userSetting defaultDocArgs)
@@ -69,7 +68,7 @@ haddockBuilderArgs = mconcat
, map ("--hide=" ++) <$> getContextData otherModules
, pure [ "--read-interface=../" ++ p
++ "," ++ baseUrl p ++ "/src/%{MODULE}.html#%{NAME},"
- ++ haddock | (p, haddock) <- zip pkgs haddocks ]
+ ++ haddock | (p, haddock) <- haddocks_with_versions ]
, pure [ "--optghc=" ++ opt | opt <- ghcOpts, not ("--package-db" `isInfixOf` opt) ]
, getInputs
, arg "+RTS"
=====================================
m4/fp_prog_ld_build_id.m4 deleted
=====================================
@@ -1,20 +0,0 @@
-# FP_PROG_LD_BUILD_ID
-# ------------
-# Sets the output variable LdHasBuildId to YES if ld supports
-# --build-id, or NO otherwise.
-AC_DEFUN([FP_PROG_LD_BUILD_ID],
-[
-AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id],
-[echo 'int foo() { return 0; }' > conftest.c
-${CC-cc} -c conftest.c
-if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then
- fp_cv_ld_build_id=yes
-else
- fp_cv_ld_build_id=no
-fi
-rm -rf conftest*])
-FP_CAPITALIZE_YES_NO(["$fp_cv_ld_build_id"], [LdHasBuildId])
-AC_SUBST([LdHasBuildId])
-])# FP_PROG_LD_BUILD_ID
-
-
=====================================
mk/config.mk.in
=====================================
@@ -724,10 +724,6 @@ OPT = @OptCmd@
# overflowing command-line length limits.
LdIsGNULd = @LdIsGNULd@
-# Set to YES if ld has the --build-id flag. Sometimes we need to
-# disable it with --build-id=none.
-LdHasBuildId = @LdHasBuildId@
-
# Set to YES if ld has the --no_compact_unwind flag. See #5019
# and GHC.Driver.Pipeline.
LdHasNoCompactUnwind = @LdHasNoCompactUnwind@
=====================================
rts/include/ghc.mk
=====================================
@@ -202,7 +202,6 @@ $(includes_SETTINGS) : rts/include/Makefile | $$(dir $$@)/.
@echo ',("ld command", "$(SettingsLdCommand)")' >> $@
@echo ',("ld flags", "$(SettingsLdFlags)")' >> $@
@echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@
- @echo ',("ld supports build-id", "$(LdHasBuildId)")' >> $@
@echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@
@echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@
@echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@
=====================================
testsuite/tests/typecheck/should_fail/T21583.hs
=====================================
@@ -0,0 +1,90 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Telomare.Possible where
+
+data PartExprF f
+ = ZeroSF
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+newtype EnhancedExpr f = EnhancedExpr {unEnhanceExpr :: SplitFunctor f PartExprF (EnhancedExpr f)} -- deriving (Eq, Show)
+
+type family Base t :: * -> *
+
+type instance Base (EnhancedExpr f) = SplitFunctor f PartExprF
+
+class Functor (Base t) => Recursive t where
+ project :: t -> Base t t
+
+instance Functor f => Recursive (EnhancedExpr f) where
+ project = unEnhanceExpr
+
+class Functor (Base t) => Corecursive t where
+ embed :: Base t t -> t
+
+instance Functor f => Corecursive (EnhancedExpr f) where
+ embed = EnhancedExpr
+
+type SimpleExpr = EnhancedExpr VoidF
+type BasicBase f = SplitFunctor f PartExprF
+type SuperBase f = BasicBase (SplitFunctor f SuperPositionF)
+type AbortBase f = SuperBase (SplitFunctor f AbortableF)
+type UnsizedBase = AbortBase UnsizedRecursionF
+
+pattern UnsizedFW :: UnsizedRecursionF a -> UnsizedBase a
+pattern UnsizedFW x = SplitFunctor (Left (SplitFunctor (Left (SplitFunctor (Left x)))))
+pattern BasicExpr :: PartExprF (EnhancedExpr f) -> EnhancedExpr f
+pattern BasicExpr x = EnhancedExpr (SplitFunctor (Right x))
+pattern UnsizedWrap :: UnsizedRecursionF UnsizedExpr -> UnsizedExpr
+pattern UnsizedWrap x = EnhancedExpr (UnsizedFW x)
+
+data VoidF f
+ deriving (Functor, Foldable, Traversable)
+
+data SuperPositionF f
+ = AnyPF
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+data AbortableF f
+ = AbortF
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+newtype SplitFunctor g f x = SplitFunctor { unSplitF :: Either (g x) (f x) } deriving (Eq, Show)
+
+instance (Functor f, Functor g) => Functor (SplitFunctor g f) where
+
+instance (Foldable f, Foldable g) => Foldable (SplitFunctor g f) where
+
+instance (Traversable f, Traversable g) => Traversable (SplitFunctor g f) where
+
+type SuperExpr f = EnhancedExpr (SplitFunctor f SuperPositionF)
+
+type AbortExpr f = SuperExpr (SplitFunctor f AbortableF)
+
+type BreakExtras = ()
+
+data UnsizedRecursionF f
+ = UnsizedRecursionF BreakExtras f
+ | UnsizedBarrierF f
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+type UnsizedExpr = AbortExpr UnsizedRecursionF
+
+cata :: Recursive t => (Base t a -> a) -> t -> a
+cata = undefined
+
+sizeTerm :: UnsizedExpr -> Maybe (AbortExpr VoidF)
+sizeTerm term =
+ let sizingTerm = eval term
+ eval :: UnsizedExpr -> UnsizedExpr
+ eval = undefined
+ setSizes sizes = cata $ \case
+ UnsizedFW (UnsizedRecursionF be env) -> BasicExpr ZeroSF
+ clean = undefined
+ hoist = undefined
+ maybeSized = pure sizingTerm
+ in hoist clean <$> maybeSized
+
+
=====================================
testsuite/tests/typecheck/should_fail/T21583.stderr
=====================================
@@ -0,0 +1,22 @@
+T21583.hs:14:23: error: [-Wstar-is-type (in -Wall, -Wcompat), -Werror=star-is-type]
+ Using ‘*’ (or its Unicode variant) to mean ‘Data.Kind.Type’
+ relies on the StarIsType extension, which will become
+ deprecated in the future.
+ Suggested fix: Use ‘Type’ from ‘Data.Kind’ instead.
+T21583.hs:14:28: error: [-Wstar-is-type (in -Wall, -Wcompat), -Werror=star-is-type]
+ Using ‘*’ (or its Unicode variant) to mean ‘Data.Kind.Type’
+ relies on the StarIsType extension, which will become
+ deprecated in the future.
+ Suggested fix: Use ‘Type’ from ‘Data.Kind’ instead.
+T21583.hs:56:10: warning: [-Wmissing-methods (in -Wdefault)]
+ • No explicit implementation for
+ ‘fmap’
+ • In the instance declaration for ‘Functor (SplitFunctor g f)’
+T21583.hs:58:10: warning: [-Wmissing-methods (in -Wdefault)]
+ • No explicit implementation for
+ either ‘foldMap’ or ‘foldr’
+ • In the instance declaration for ‘Foldable (SplitFunctor g f)’
+T21583.hs:60:10: warning: [-Wmissing-methods (in -Wdefault)]
+ • No explicit implementation for
+ either ‘traverse’ or ‘sequenceA’
+ • In the instance declaration for ‘Traversable (SplitFunctor g f)’
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -657,3 +657,4 @@ test('T20768_fail', normal, compile_fail, [''])
test('T21327', normal, compile_fail, [''])
test('T21338', normal, compile_fail, [''])
test('T21158', normal, compile_fail, [''])
+test('T21583', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd7a14e5cb04e9a65e212f56f62896adeb95dde7...021b1184857c8e68cc38d2d11ece0a6addf41b94
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd7a14e5cb04e9a65e212f56f62896adeb95dde7...021b1184857c8e68cc38d2d11ece0a6addf41b94
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/20220818/23821a76/attachment-0001.html>
More information about the ghc-commits
mailing list