[Git][ghc/ghc][master] Always refresh profiling CCSes after running pending initializers

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
119586ea by Alexis King at 2024-01-19T00:08:00-05:00
Always refresh profiling CCSes after running pending initializers

Fixes #24171.

- - - - -


6 changed files:

- rts/Linker.c
- + testsuite/tests/rts/linker/T24171/Lib.hs
- + testsuite/tests/rts/linker/T24171/Makefile
- + testsuite/tests/rts/linker/T24171/T24171.stdout
- + testsuite/tests/rts/linker/T24171/all.T
- + testsuite/tests/rts/linker/T24171/main.c


Changes:

=====================================
rts/Linker.c
=====================================
@@ -1020,12 +1020,6 @@ SymbolAddr* loadSymbol(SymbolName *lbl, RtsSymbolInfo *pinfo) {
         if (!r) {
             return NULL;
         }
-
-#if defined(PROFILING)
-        // collect any new cost centres & CCSs
-        // that were defined during runInit
-        refreshProfilingCCSs();
-#endif
     }
 
     return pinfo->value;
@@ -1774,6 +1768,12 @@ int runPendingInitializers (void)
             return r;
         }
     }
+
+#if defined(PROFILING)
+    // collect any new cost centres & CCSs that were defined during runInit
+    refreshProfilingCCSs();
+#endif
+
     return 1;
 }
 
@@ -1800,11 +1800,6 @@ static HsInt resolveObjs_ (void)
         return 0;
     }
 
-#if defined(PROFILING)
-    // collect any new cost centres & CCSs that were defined during runInit
-    refreshProfilingCCSs();
-#endif
-
     IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
     return 1;
 }


=====================================
testsuite/tests/rts/linker/T24171/Lib.hs
=====================================
@@ -0,0 +1,20 @@
+module Lib (globalInt, chooseInt) where
+
+import Data.IORef
+import System.IO.Unsafe (unsafePerformIO)
+
+foreign export ccall chooseInt :: Bool -> Int
+
+globalInt :: IORef Int
+globalInt = unsafePerformIO $ newIORef 5
+{-# NOINLINE globalInt #-}
+
+add1 :: Int -> Int
+add1 x = x + 1
+{-# OPAQUE add1 #-}
+
+chooseInt :: Bool -> Int
+chooseInt = unsafePerformIO $ do
+  x <- readIORef globalInt
+  let y = add1 x -- intentionally build a thunk
+  pure (\b -> if b then y else x)


=====================================
testsuite/tests/rts/linker/T24171/Makefile
=====================================
@@ -0,0 +1,24 @@
+.PHONY: clean_build_and_run build_and_run clean build
+
+clean_build_and_run:
+	$(MAKE) clean
+	$(MAKE) build_and_run
+
+build_and_run: build
+	./main
+	grep -c Lib main.hp
+
+clean:
+	$(RM) Lib.o Lib_stub.h Lib.hi Lib.a main.o main main.hp
+
+build: Lib.a main
+
+Lib.o: Lib.hs
+	"$(TEST_HC)" $(TEST_HC_OPTS) -c -O -fPIC -prof Lib.hs -o Lib.o
+Lib.a: Lib.o
+	llvm-ar -qcL Lib.a Lib.o 2>/dev/null || ar -qc Lib.a Lib.o
+
+main: main.c
+	"$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \
+		-rdynamic -no-hs-main -optc-Werror -prof \
+		main.c -o main


=====================================
testsuite/tests/rts/linker/T24171/T24171.stdout
=====================================
@@ -0,0 +1,2 @@
+chooseInt(0) = 5
+1


=====================================
testsuite/tests/rts/linker/T24171/all.T
=====================================
@@ -0,0 +1,6 @@
+test('T24171',
+     [req_rts_linker,
+      req_profiling,
+      extra_files(['Lib.hs', 'main.c'])],
+     makefile_test,
+     ['clean_build_and_run'])


=====================================
testsuite/tests/rts/linker/T24171/main.c
=====================================
@@ -0,0 +1,57 @@
+#include "Rts.h"
+
+#if defined(mingw32_HOST_OS)
+#define PATH_STR(str) L##str
+#else
+#define PATH_STR(str) str
+#endif
+
+int main(int argc, char *argv[])
+{
+  RtsConfig conf = defaultRtsConfig;
+  conf.rts_opts_enabled = RtsOptsAll;
+  conf.rts_opts = "-hm -hbvoid --no-automatic-heap-samples";
+  hs_init_ghc(&argc, &argv, conf);
+
+  initLinker_(0);
+
+  int ok;
+  ok = loadArchive(PATH_STR("Lib.a"));
+  if (!ok) {
+    errorBelch("loadArchive(Lib.a) failed");
+    return 1;
+  }
+  ok = resolveObjs();
+  if (!ok) {
+    errorBelch("resolveObjs() failed");
+    return 1;
+  }
+
+  StgInt (*chooseInt)(StgBool) = lookupSymbol("chooseInt");
+  if (!chooseInt) {
+    errorBelch("lookupSymbol(chooseInt) failed");
+    return 1;
+  }
+
+  printf("chooseInt(0) = %" FMT_Int "\n", chooseInt(0));
+
+  requestHeapCensus();
+  performMajorGC();
+
+  ok = resolveObjs();
+  if (!ok) {
+    errorBelch("resolveObjs() failed");
+    return 1;
+  }
+  ok = unloadObj(PATH_STR("Lib.a"));
+  if (!ok) {
+    errorBelch("unloadObj(Lib.a) failed");
+    return 1;
+  }
+
+  requestHeapCensus();
+  performMajorGC();
+
+  hs_exit();
+  return 0;
+}



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/119586eacb2448551d479d375a2abaad3f5f1f14

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/119586eacb2448551d479d375a2abaad3f5f1f14
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/20240119/00d92399/attachment-0001.html>