[Git][ghc/ghc][wip/deb9-failure] 3 commits: metrics: Widen libdir and size_hello_obj acceptance window
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Nov 29 17:25:36 UTC 2023
Matthew Pickering pushed to branch wip/deb9-failure at Glasgow Haskell Compiler / GHC
Commits:
f6c486c3 by Matthew Pickering at 2023-11-29T11:08:13-05:00
metrics: Widen libdir and size_hello_obj acceptance window
af8816740d9b8759be1a22af8adcb5f13edeb61d shows that the libdir size can
fluctuate quite significantly even when the change is quite small.
Therefore we widen the acceptance window to 10%.
- - - - -
99a6a49c by Alan Zimmerman at 2023-11-29T11:08:49-05:00
EPA: Clean up TC Monad Utils
We no longer need the alternative variant of addLocM (addLocMA)
nor wrapLocAM, wrapLocSndMA.
aarch64-darwin
Metric Increase:
MultiLayerModulesTH_OneShot
deb10-numa-slow
Metric Decrease:
libdir
- - - - -
7c57408d by Matthew Pickering at 2023-11-29T17:25:20+00:00
testsuite: Fix T21097b test with make 4.1 (deb9)
cee81370cd6ef256f66035e3116878d4cb82e28b recently added a test which
failed on deb9 because the version of make was emitting the recipe
failure to stdout rather than stderr.
One way to fix this is to be more precise in the test about which part
of the output we care about inspecting.
- - - - -
11 changed files:
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- testsuite/tests/driver/T21097b/T21097b.stdout
- testsuite/tests/driver/T21097b/all.T
- testsuite/tests/perf/size/all.T
Changes:
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -459,7 +459,7 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
rnBindLHS name_maker _ (PatSynBind x psb at PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
- = do { addLocMA checkConName rdrname
+ = do { addLocM checkConName rdrname
; name <-
lookupLocatedTopConstructorRnN rdrname -- Should be in scope already
; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -276,7 +276,7 @@ rnSrcWarnDecls bndr_set decls'
; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups
in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))
warn_rdr_dups
- ; pairs_s <- mapM (addLocMA rn_deprec) decls
+ ; pairs_s <- mapM (addLocM rn_deprec) decls
; return $ concat pairs_s }
where
decls = concatMap (wd_warnings . unLoc) decls'
@@ -1891,7 +1891,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
= do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData
; unless (null (fromMaybeContext context)) $
failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts
- ; mapM_ (addLocMA check_type_data_condecl) condecls
+ ; mapM_ (addLocM check_type_data_condecl) condecls
; unless (null derivs) $
failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses
}
@@ -2384,7 +2384,7 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt, con_args = args
, con_doc = mb_doc, con_forall = forall_ })
- = do { _ <- addLocMA checkConName name
+ = do { _ <- addLocM checkConName name
; new_name <- lookupLocatedTopConstructorRnN name
-- We bind no implicit binders here; this is just like
@@ -2421,7 +2421,7 @@ rnConDecl (ConDeclGADT { con_names = names
, con_g_args = args
, con_res_ty = res_ty
, con_doc = mb_doc })
- = do { mapM_ (addLocMA checkConName) names
+ = do { mapM_ (addLocM checkConName) names
; new_names <- mapM (lookupLocatedTopConstructorRnN) names
; let -- We must ensure that we extract the free tkvs in left-to-right
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -223,7 +223,7 @@ tcCompleteSigs sigs =
-- compatible with the result type constructor 'mb_tc'.
doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm))
= fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do
- cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns
+ cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns
mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm
pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }
doOne _ = return Nothing
@@ -239,7 +239,7 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
tcHsBootSigs binds sigs
= do { unless (null binds) $
rejectBootDecls HsBoot BootBindsRn (concatMap (bagToList . snd) binds)
- ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) }
+ ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
where
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1516,7 +1516,7 @@ inferInitialKinds decls
; traceTc "inferInitialKinds done }" empty
; return tcs }
where
- infer_initial_kind = addLocMA (getInitialKind InitialKindInfer)
+ infer_initial_kind = addLocM (getInitialKind InitialKindInfer)
-- Check type/class declarations against their standalone kind signatures or
-- CUSKs, producing a generalized TcTyCon for each.
@@ -1528,7 +1528,7 @@ checkInitialKinds decls
; return tcs }
where
check_initial_kind (ldecl, msig) =
- addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
+ addLocM (getInitialKind (InitialKindCheck msig)) ldecl
-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
-- depending on the 'InitialKindStrategy'.
@@ -1556,7 +1556,7 @@ getInitialKind strategy
-- See Note [Don't process associated types in getInitialKind]
; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $
- mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats
+ mapM (addLocM (getAssocFamInitialKind cls_tc)) ats
; return (cls_tc : at_tcs) }
where
getAssocFamInitialKind cls =
@@ -2621,7 +2621,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
-- The (binderVars tc_bndrs) is needed bring into scope the
-- skolems bound by the class decl header (#17841)
do { ctxt <- tcHsContext hs_ctxt
- ; fds <- mapM (addLocMA tc_fundep) fundeps
+ ; fds <- mapM (addLocM tc_fundep) fundeps
; sig_stuff <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name clas ats at_defs
; return (ctxt, fds, sig_stuff, at_stuff) }
@@ -2724,7 +2724,7 @@ tcClassATs class_name cls ats at_defs
(at_def_tycon at_def) [at_def])
emptyNameEnv at_defs
- tc_at at = do { (fam_tc, val_infos) <- addLocMA (tcFamDecl1 (Just cls)) at
+ tc_at at = do { (fam_tc, val_infos) <- addLocM (tcFamDecl1 (Just cls)) at
; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos
; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
`orElse` []
@@ -3579,7 +3579,7 @@ tcConDecls :: DataDeclInfo
-> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon)
tcConDecls dd_info rep_tycon tmpl_bndrs res_kind
= concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data ->
- addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon)
+ addLocM $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon)
-- mkTyConTagMap: it's important that we pay for tag allocation here,
-- once per TyCon. See Note [Constructor tag allocation], fixes #14657
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -237,7 +237,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
= do { -- No default method
- mapM_ (addLocMA (badDmPrag sel_id ))
+ mapM_ (addLocM (badDmPrag sel_id ))
(lookupPragEnv prag_fn (idName sel_id))
; return emptyBag }
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -2425,7 +2425,7 @@ Note that
tcSpecInstPrags :: DFunId -> InstBindings GhcRn
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
- = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $
+ = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
filter isSpecInstLSig uprags
-- The filter removes the pragmas for methods
; return (spec_inst_prags, mkPragEnv uprags binds) }
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -218,7 +218,7 @@ span of the Name.
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
-- c.f. GHC.IfaceToCore.tcIfaceGlobal
tcLookupLocatedGlobal name
- = addLocMA tcLookupGlobal name
+ = addLocM tcLookupGlobal name
tcLookupGlobal :: Name -> TcM TyThing
-- The Name is almost always an ExternalName, but not always
@@ -308,13 +308,13 @@ tcLookupAxiom name = do
_ -> wrongThingErr WrongThingAxiom (AGlobal thing) name
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
-tcLookupLocatedGlobalId = addLocMA tcLookupId
+tcLookupLocatedGlobalId = addLocM tcLookupId
tcLookupLocatedClass :: LocatedA Name -> TcM Class
-tcLookupLocatedClass = addLocMA tcLookupClass
+tcLookupLocatedClass = addLocM tcLookupClass
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
-tcLookupLocatedTyCon = addLocMA tcLookupTyCon
+tcLookupLocatedTyCon = addLocM tcLookupTyCon
-- Find the instance that exactly matches a type class application. The class arguments must be precisely
-- the same as in the instance declaration (modulo renaming & casts).
@@ -440,7 +440,7 @@ tcExtendRecEnv gbl_stuff thing_inside
-}
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
-tcLookupLocated = addLocMA tcLookup
+tcLookupLocated = addLocM tcLookup
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe name
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -61,9 +61,9 @@ module GHC.Tc.Utils.Monad(
addDependentFiles,
-- * Error management
- getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA,
+ getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
inGeneratedCode, setInGeneratedCode,
- wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
+ wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
wrapLocMA_,wrapLocMA,
getErrsVar, setErrsVar,
addErr,
@@ -995,18 +995,15 @@ setInGeneratedCode thing_inside =
setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
-addLocM :: (a -> TcM b) -> Located a -> TcM b
-addLocM fn (L loc a) = setSrcSpan loc $ fn a
+addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b
+addLocM fn (L loc a) = setSrcSpan (getHasLoc loc) $ fn a
-addLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcM b
-addLocMA fn (L loc a) = setSrcSpanA loc $ fn a
-
-wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
-wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
- ; return (L loc b) }
-
-wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
-wrapLocAM fn a = wrapLocM fn (reLoc a)
+wrapLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM (Located b)
+wrapLocM fn (L loc a) =
+ let
+ loc' = getHasLoc loc
+ in setSrcSpan loc' $ do { b <- fn a
+ ; return (L loc' b) }
wrapLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
=====================================
testsuite/tests/driver/T21097b/T21097b.stdout
=====================================
@@ -1,5 +1 @@
-
-==================== Module Map ====================
Foo a-0.1 (exposed package)
-
-
=====================================
testsuite/tests/driver/T21097b/all.T
=====================================
@@ -1,6 +1,15 @@
+def normalise_t21097b_output(s):
+ res = ""
+ for l in s.splitlines():
+ if 'Foo' in l:
+ res += l
+ res += "\n"
+ return res
+
# Package b is unusable (broken dependency) and reexport Foo from a (which is usable)
test('T21097b',
[ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"])
, ignore_stderr
+ , normalise_fun(normalise_t21097b_output)
, exit_code(2)
], makefile_test, [])
=====================================
testsuite/tests/perf/size/all.T
=====================================
@@ -1,3 +1,3 @@
-test('size_hello_obj', [collect_size(3, 'size_hello_obj.o')], compile, [''])
+test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, [''])
-test('libdir',[stat_from_file('size', 3, 'SIZE')], makefile_test, ['libdir_size'] )
+test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] )
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/831207dc124c2ac15d9ed99f2f9a85afa6c1f4fb...7c57408d8b0d85dd7faf69df7903863ff17b72a6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/831207dc124c2ac15d9ed99f2f9a85afa6c1f4fb...7c57408d8b0d85dd7faf69df7903863ff17b72a6
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/20231129/88effd7c/attachment-0001.html>
More information about the ghc-commits
mailing list