[Git][ghc/ghc][wip/t22549] 4 commits: rts: improve memory ordering and add some comments in the StablePtr implementation
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Apr 14 15:18:45 UTC 2023
Matthew Pickering pushed to branch wip/t22549 at Glasgow Haskell Compiler / GHC
Commits:
a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00
rts: improve memory ordering and add some comments in the StablePtr implementation
- - - - -
d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00
docs: Generate docs/index.html with version number
* Generate docs/index.html to include the version of the ghc library
* This also fixes the packageVersions interpolations which were
- Missing an interpolation for `LIBRARY_ghc_VERSION`
- Double quoting the version so that "9.7" was being inserted.
Fixes #23121
- - - - -
d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00
Stop if type constructors have kind errors
Otherwise we get knock-on errors, such as #23252.
This makes GHC fail a bit sooner, and I have not attempted to add
recovery code, to add a fake TyCon place of the erroneous one,
in an attempt to get more type errors in one pass. We could
do that (perhaps) if there was a call for it.
- - - - -
7068ed9b by Simon Peyton Jones at 2023-04-14T16:18:11+01:00
Transfer DFunId_ness onto specialised bindings
Whether a binding is a DFunId or not has consequences for the `-fdicts-strict`
flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does
not apply because the constraint solver can create recursive groups of dictionaries.
In #22549 this was fixed for the "normal" case, see
Note [Do not strictify the argument dictionaries of a dfun].
However the loop still existed if the DFunId was being specialised.
The problem was that the specialiser would specialise a DFunId and
turn it into a VanillaId and so the demand analyser didn't know to
apply special treatment to the binding anymore and the whole recursive
group was optimised to bottom.
The solution is to transfer over the DFunId-ness of the binding in the specialiser so
that the demand analyser knows not to apply the `-fstrict-dicts`.
Fixes #22549
- - - - -
11 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Tc/TyCl.hs
- docs/index.html → docs/index.html.in
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- rts/StablePtr.c
- testsuite/tests/dependent/should_fail/T15743c.hs
- testsuite/tests/dependent/should_fail/T15743c.stderr
- + testsuite/tests/roles/should_fail/T23252.hs
- + testsuite/tests/roles/should_fail/T23252.stderr
- testsuite/tests/roles/should_fail/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -48,10 +48,11 @@ import GHC.Types.Unique.DFM
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
-import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg )
+import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
+import GHC.Types.Id.Info
import GHC.Types.Error
import GHC.Utils.Error ( mkMCDiagnostic )
@@ -59,6 +60,7 @@ import GHC.Utils.Monad ( foldlM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain( assert )
import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
@@ -1748,12 +1750,44 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
| otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
join_arity_decr = length rule_lhs_args - length spec_bndrs
- spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
- = Just (orig_join_arity - join_arity_decr)
- | otherwise
- = Nothing
- ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity
+ --------------------------------------
+ -- Add a suitable unfolding; see Note [Inline specialisations]
+ -- The wrap_unf_body applies the original unfolding to the specialised
+ -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
+ simpl_opts = initSimpleOpts dflags
+ wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
+ spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
+ rule_lhs_args fn_unf
+
+ --------------------------------------
+ -- Adding arity information just propagates it a bit faster
+ -- See Note [Arity decrease] in GHC.Core.Opt.Simplify
+ -- Copy InlinePragma information from the parent Id.
+ -- So if f has INLINE[1] so does spec_fn
+ arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
+
+ spec_inl_prag
+ | not is_local -- See Note [Specialising imported functions]
+ , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
+ = neverInlinePragma
+ | otherwise
+ = inl_prag
+
+ spec_fn_info
+ = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr)
+ `setInlinePragInfo` spec_inl_prag
+ `setUnfoldingInfo` spec_unf
+
+ -- Compute the IdDetails of the specialise Id
+ -- See Note [Transfer IdDetails during specialisation]
+ spec_fn_details
+ = case idDetails fn of
+ JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing
+ DFunId is_nt -> DFunId is_nt
+ _ -> VanillaId
+
+ ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info
; let
-- The rule to put in the function's specialisation is:
-- forall x @b d1' d2'.
@@ -1768,33 +1802,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
herald fn rule_bndrs rule_lhs_args
(mkVarApps (Var spec_fn) spec_bndrs)
- simpl_opts = initSimpleOpts dflags
-
- --------------------------------------
- -- Add a suitable unfolding; see Note [Inline specialisations]
- -- The wrap_unf_body applies the original unfolding to the specialised
- -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
- wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
- spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
- rule_lhs_args fn_unf
-
- spec_inl_prag
- | not is_local -- See Note [Specialising imported functions]
- , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
- = neverInlinePragma
- | otherwise
- = inl_prag
-
- --------------------------------------
- -- Adding arity information just propagates it a bit faster
- -- See Note [Arity decrease] in GHC.Core.Opt.Simplify
- -- Copy InlinePragma information from the parent Id.
- -- So if f has INLINE[1] so does spec_fn
- arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
- spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)
- `setInlinePragma` spec_inl_prag
- `setIdUnfolding` spec_unf
- `asJoinId_maybe` spec_join_arity
+ spec_f_w_arity = spec_fn
_rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type
, ppr spec_fn <+> dcolon <+> ppr spec_fn_ty
@@ -1824,7 +1832,7 @@ specLookupRule env fn args phase rules
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-DFuns have a special sort of unfolding (DFunUnfolding), and these are
+DFuns have a special sort of unfolding (DFunUnfolding), and it is
hard to specialise a DFunUnfolding to give another DFunUnfolding
unless the DFun is fully applied (#18120). So, in the case of DFunIds
we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,
@@ -1833,6 +1841,36 @@ so that we'll generate a rule that completely saturates the DFun.
There is an ASSERT that checks this, in the DFunUnfolding case of
GHC.Core.Unfold.Make.specUnfolding.
+Note [Transfer IdDetails during specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When specialising a function, `newSpecIdSM` comes up with a fresh Id the
+specialised RHS will be bound to. It is critical that we get the `IdDetails` of
+the specialised Id correct:
+
+* JoinId: We want the specialised Id to be a join point, too. But
+ we have to carefully adjust the arity
+
+* DFunId: It is crucial that we also make the new Id a DFunId.
+ - First, because it obviously /is/ a DFun, having a DFunUnfolding and
+ all that; see Note [Specialising DFuns]
+
+ - Second, DFuns get very delicate special treatment in the demand analyser;
+ see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't
+ also a DFunId, this special treatment doesn't happen, so the demand
+ analyser makes a too-strict DFun, and we get an infinite loop. See Note
+ [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.
+ #22549 describes the loop, and (lower down) a case where a /specialised/
+ DFun caused a loop.
+
+* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come
+ up when specialising imports. We must keep them as VanillaIds because WW
+ will detect them as WorkerLikeIds again. That is, unless specialisation
+ allows unboxing of all previous CBV args, in which case sticking to
+ VanillaIds was the only correct choice to begin with.
+
+* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:
+ Never specialised.
+
Note [Specialisation Must Preserve Sharing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a function:
@@ -3439,15 +3477,14 @@ newDictBndr env@(SE { se_subst = subst }) b
env' = env { se_subst = subst `Core.extendSubstInScope` b' }
; pure (env', b') }
-newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
+newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id
-- Give the new Id a similar occurrence name to the old one
-newSpecIdSM old_id new_ty join_arity_maybe
+newSpecIdSM old_name new_ty details info
= do { uniq <- getUniqueM
- ; let name = idName old_id
- new_occ = mkSpecOcc (nameOccName name)
- new_id = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name)
- `asJoinId_maybe` join_arity_maybe
- ; return new_id }
+ ; let new_occ = mkSpecOcc (nameOccName old_name)
+ new_name = mkInternalName uniq new_occ (getSrcSpan old_name)
+ ; return (assert (not (isCoVarType new_ty)) $
+ mkLocalVar details new_name ManyTy new_ty info) }
{-
Old (but interesting) stuff about unboxed bindings
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -248,7 +248,13 @@ tcTyClDecls tyclds kisig_env role_annots
= do { -- Step 1: kind-check this group and returns the final
-- (possibly-polymorphic) kind of each TyCon and Class
-- See Note [Kind checking for type and class decls]
- (tc_tycons, kindless) <- kcTyClGroup kisig_env tyclds
+ (tc_tycons, kindless) <- checkNoErrs $
+ kcTyClGroup kisig_env tyclds
+ -- checkNoErrs: If the TyCons are ill-kinded, stop now. Else we
+ -- can get follow-on errors. Example: #23252, where the TyCon
+ -- had an ill-scoped kind forall (d::k) k (a::k). blah
+ -- and that ill-scoped kind made role inference fall over.
+
; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
-- Step 2: type-check all groups together, returning
=====================================
docs/index.html → docs/index.html.in
=====================================
@@ -39,7 +39,7 @@
<LI>
<P>
- <B><A HREF="libraries/ghc/index.html">GHC API</A></B>
+ <B><A HREF="libraries/ghc- at LIBRARY_ghc_VERSION@/index.html">GHC API</A></B>
</P>
<P>
Documentation for the GHC API.
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -193,7 +193,7 @@ buildHtmlDocumentation = do
| SphinxHTML `Set.member` doctargets ]
need $ map ((root -/-) . pathIndex) targets
- copyFileUntracked "docs/index.html" file
+ copyFile "docs/index.html" file
-- | Compile a Sphinx ReStructured Text package to HTML.
buildSphinxHtml :: FilePath -> Rules ()
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -305,10 +305,10 @@ rtsCabalFlags = mconcat
flag = interpolateCabalFlag
packageVersions :: Interpolations
-packageVersions = foldMap f [ base, ghcPrim, ghc, cabal, templateHaskell, ghcCompact, array ]
+packageVersions = foldMap f [ base, ghcPrim, compiler, ghc, cabal, templateHaskell, ghcCompact, array ]
where
f :: Package -> Interpolations
- f pkg = interpolateVar var $ show . version <$> readPackageData pkg
+ f pkg = interpolateVar var $ version <$> readPackageData pkg
where var = "LIBRARY_" <> pkgName pkg <> "_VERSION"
templateRule :: FilePath -> Interpolations -> Rules ()
@@ -335,6 +335,7 @@ templateRules = do
templateRule "utils/ghc-pkg/ghc-pkg.cabal" $ projectVersion
templateRule "libraries/template-haskell/template-haskell.cabal" $ projectVersion
templateRule "libraries/prologue.txt" $ packageVersions
+ templateRule "docs/index.html" $ packageVersions
-- Generators
=====================================
rts/StablePtr.c
=====================================
@@ -98,8 +98,13 @@
*/
+// the global stable pointer entry table
spEntry *stable_ptr_table = NULL;
+
+// the next free stable ptr, the free entries form a linked list where spEntry.addr points to the next after
static spEntry *stable_ptr_free = NULL;
+
+// current stable pointer table size
static unsigned int SPT_size = 0;
#define INIT_SPT_SIZE 64
@@ -117,6 +122,7 @@ static unsigned int SPT_size = 0;
#error unknown SIZEOF_VOID_P
#endif
+// old stable pointer tables
static spEntry *old_SPTs[MAX_N_OLD_SPTS];
static uint32_t n_old_SPTs = 0;
@@ -149,8 +155,9 @@ stablePtrUnlock(void)
* -------------------------------------------------------------------------- */
STATIC_INLINE void
-initSpEntryFreeList(spEntry *table, uint32_t n, spEntry *free)
+initSpEntryFreeList(spEntry *table, uint32_t n)
{
+ spEntry* free = NULL;
spEntry *p;
for (p = table + n - 1; p >= table; p--) {
p->addr = (P_)free;
@@ -166,7 +173,7 @@ initStablePtrTable(void)
SPT_size = INIT_SPT_SIZE;
stable_ptr_table = stgMallocBytes(SPT_size * sizeof(spEntry),
"initStablePtrTable");
- initSpEntryFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);
+ initSpEntryFreeList(stable_ptr_table,INIT_SPT_SIZE);
#if defined(THREADED_RTS)
initMutex(&stable_ptr_mutex);
@@ -181,6 +188,8 @@ initStablePtrTable(void)
static void
enlargeStablePtrTable(void)
{
+ ASSERT_LOCK_HELD(&stable_ptr_mutex);
+
uint32_t old_SPT_size = SPT_size;
spEntry *new_stable_ptr_table;
@@ -206,7 +215,8 @@ enlargeStablePtrTable(void)
*/
RELEASE_STORE(&stable_ptr_table, new_stable_ptr_table);
- initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
+ // add the new entries to the free list
+ initSpEntryFreeList(stable_ptr_table + old_SPT_size, old_SPT_size);
}
/* Note [Enlarging the stable pointer table]
@@ -245,6 +255,7 @@ exitStablePtrTable(void)
{
if (stable_ptr_table)
stgFree(stable_ptr_table);
+
stable_ptr_table = NULL;
SPT_size = 0;
@@ -265,12 +276,17 @@ freeSpEntry(spEntry *sp)
void
freeStablePtrUnsafe(StgStablePtr sp)
{
+ ASSERT_LOCK_HELD(&stable_ptr_mutex);
+
// see Note [NULL StgStablePtr]
if (sp == NULL) {
return;
}
+
StgWord spw = (StgWord)sp - 1;
+
ASSERT(spw < SPT_size);
+
freeSpEntry(&stable_ptr_table[spw]);
}
@@ -278,25 +294,35 @@ void
freeStablePtr(StgStablePtr sp)
{
stablePtrLock();
+
freeStablePtrUnsafe(sp);
+
stablePtrUnlock();
}
/* -----------------------------------------------------------------------------
- * Looking up
+ * Allocating stable pointers
* -------------------------------------------------------------------------- */
StgStablePtr
getStablePtr(StgPtr p)
{
- StgWord sp;
-
stablePtrLock();
- if (!stable_ptr_free) enlargeStablePtrTable();
- sp = stable_ptr_free - stable_ptr_table;
- stable_ptr_free = (spEntry*)(stable_ptr_free->addr);
- RELAXED_STORE(&stable_ptr_table[sp].addr, p);
+
+ if (!stable_ptr_free)
+ enlargeStablePtrTable();
+
+ // find the index of free stable ptr
+ StgWord sp = stable_ptr_free - stable_ptr_table;
+
+ // unlink the table entry we grabbed from the free list
+ stable_ptr_free = (spEntry*)(stable_ptr_free->addr);
+
+ // release store to pair with acquire load in deRefStablePtr
+ RELEASE_STORE(&stable_ptr_table[sp].addr, p);
+
stablePtrUnlock();
+
// see Note [NULL StgStablePtr]
sp = sp + 1;
return (StgStablePtr)(sp);
=====================================
testsuite/tests/dependent/should_fail/T15743c.hs
=====================================
@@ -8,4 +8,4 @@ import Data.Proxy
data SimilarKind :: forall (c :: k) (d :: k). Proxy c -> Proxy d -> Type
data T k (c :: k) (a :: Proxy c) b (x :: SimilarKind a b)
-data T2 k (c :: k) (a :: Proxy c) (b :: Proxy d) (x :: SimilarKind a b)
+
=====================================
testsuite/tests/dependent/should_fail/T15743c.stderr
=====================================
@@ -13,18 +13,3 @@ T15743c.hs:10:1: error:
(b :: Proxy d)
(x :: SimilarKind a b)
• In the data type declaration for ‘T’
-
-T15743c.hs:11:1: error:
- • The kind of ‘T2’ is ill-scoped
- Inferred kind: T2 :: forall (d :: k).
- forall k (c :: k) (a :: Proxy c) (b :: Proxy d) ->
- SimilarKind a b -> *
- NB: Specified variables (namely: (d :: k)) always come first
- Perhaps try this order instead:
- k
- (d :: k)
- (c :: k)
- (a :: Proxy c)
- (b :: Proxy d)
- (x :: SimilarKind a b)
- • In the data type declaration for ‘T2’
=====================================
testsuite/tests/roles/should_fail/T23252.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE PolyKinds, DataKinds, ExplicitForAll #-}
+{-# LANGUAGE RoleAnnotations #-}
+
+module T15743 where
+
+import Data.Kind
+import Data.Proxy
+
+data SimilarKind :: forall (c :: k) (d :: k). Proxy c -> Proxy d -> Type
+
+data T2 k (c :: k) (a :: Proxy c) (b :: Proxy d) (x :: SimilarKind a b)
+type role T2 nominal nominal nominal nominal -- Too few!
=====================================
testsuite/tests/roles/should_fail/T23252.stderr
=====================================
@@ -0,0 +1,14 @@
+T23252.hs:11:1: error:
+ • The kind of ‘T2’ is ill-scoped
+ Inferred kind: T2 :: forall (d :: k).
+ forall k (c :: k) (a :: Proxy c) (b :: Proxy d) ->
+ SimilarKind a b -> *
+ NB: Specified variables (namely: (d :: k)) always come first
+ Perhaps try this order instead:
+ k
+ (d :: k)
+ (c :: k)
+ (a :: Proxy c)
+ (b :: Proxy d)
+ (x :: SimilarKind a b)
+ • In the data type declaration for ‘T2’
=====================================
testsuite/tests/roles/should_fail/all.T
=====================================
@@ -8,3 +8,4 @@ test('Roles12', [], makefile_test, [])
test('T8773', normal, compile_fail, [''])
test('T9204', [], makefile_test, [])
test('RolesIArray', normal, compile_fail, [''])
+test('T23252', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1efcc6e47c24796f5779573247dd23ff4bcb3178...7068ed9ba68ca8723f781412bd38eb76c9d7d9d2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1efcc6e47c24796f5779573247dd23ff4bcb3178...7068ed9ba68ca8723f781412bd38eb76c9d7d9d2
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/20230414/08e89e2a/attachment-0001.html>
More information about the ghc-commits
mailing list