[Git][ghc/ghc][wip/libdir-bytes] 4 commits: metrics: Widen libdir and size_hello_obj acceptance window
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Nov 29 17:25:07 UTC 2023
Matthew Pickering pushed to branch wip/libdir-bytes 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
- - - - -
f70a9acd by Matthew Pickering at 2023-11-29T17:24:49+00:00
testsuite: Track size of libdir in bytes
For consistency it's better if we track all size metrics in bytes.
Metric Increase:
libdir
- - - - -
521f1f1a by Matthew Pickering at 2023-11-29T17:24:49+00:00
testsuite: Remove rogue trace in testsuite
I accidentally left a trace in the generics metric patch.
- - - - -
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/driver/testlib.py
- testsuite/tests/perf/size/Makefile
- 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/driver/testlib.py
=====================================
@@ -1810,7 +1810,6 @@ def metric_dict(name, way, metric, value) -> PerfStat:
def check_generic_stats(name, way, get_stats):
for (metric, gen_stat) in get_stats.items():
res = report_stats(name, way, metric, gen_stat)
- print(res)
if badResult(res):
return res
return passed()
=====================================
testsuite/tests/perf/size/Makefile
=====================================
@@ -3,5 +3,5 @@ include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
libdir_size:
- du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE
+ du --block-size=1 -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE
=====================================
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/b1703fddebecb4303b1a00b2b5d1fa1c2cb1f1a6...521f1f1aa43449d4d1e310e4196ebcf38f325bf4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b1703fddebecb4303b1a00b2b5d1fa1c2cb1f1a6...521f1f1aa43449d4d1e310e4196ebcf38f325bf4
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/faf03515/attachment-0001.html>
More information about the ghc-commits
mailing list