[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