Give Cmm files fake ModuleNames which include full filepathwip/ghc-prof-info

This fixes the initialisation functions when using -prof or
-finfo-table-map.

Fixes #21370

8 files changed, 47 insertions, 4 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 7fd07d31cf..b1f2b2bdac 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1731,8 +1731,8 @@ hscInteractive hsc_env cgguts location = do
 
 ------------------------------
 
-hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)
-hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
+hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
+hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do
     let dflags   = hsc_dflags hsc_env
         logger   = hsc_logger hsc_env
         hooks    = hsc_hooks hsc_env
@@ -1743,7 +1743,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
         do_info_table = gopt Opt_InfoTableMap dflags
         -- Make up a module name to give the NCG. We can't pass bottom here
         -- lest we reproduce #11784.
-        mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
+        mod_name = mkModuleName $ "Cmm$" ++ original_filename
         cmm_mod = mkHomeModule home_unit mod_name
     (cmm, ents) <- ioMsgMaybe
                $ do
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index da214cdc20..4f2c30c5a7 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -128,7 +128,7 @@ runPhase (T_Cmm pipe_env hsc_env input_fn) = do
   let dflags = hsc_dflags hsc_env
   let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)
   output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
-  mstub <- hscCompileCmmFile hsc_env input_fn output_fn
+  mstub <- hscCompileCmmFile hsc_env (src_filename pipe_env) input_fn output_fn
   stub_o <- mapM (compileStub hsc_env) mstub
   let foreign_os = maybeToList stub_o
   return (foreign_os, output_fn)
diff --git a/testsuite/tests/cmm/should_compile/T21370/Main.hs b/testsuite/tests/cmm/should_compile/T21370/Main.hs
new file mode 100644
index 0000000000..bcd34e1b4f
--- /dev/null
+++ b/testsuite/tests/cmm/should_compile/T21370/Main.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+module Main where
+
+import GHC.Int
+import GHC.Prim
+
+foreign import prim "test" test :: Int# -> Int#
+foreign import prim "test2" test2 :: Int# -> Int#
+foreign import prim "test3" test3 :: Int# -> Int#
+
+main = print (I# (test3 (test2 (test 0#))))
diff --git a/testsuite/tests/cmm/should_compile/T21370/Makefile b/testsuite/tests/cmm/should_compile/T21370/Makefile
new file mode 100644
index 0000000000..0c2bcd11f4
--- /dev/null
+++ b/testsuite/tests/cmm/should_compile/T21370/Makefile
@@ -0,0 +1,14 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+## check if -ddump-cmm-verbose -ddump-to-file generates files
+# for all cmm stages and dumps correspond to correct procs
+T21370:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c test.cmm -finfo-table-map
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c test2.cmm -finfo-table-map
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c subdir/test.cmm -finfo-table-map
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c Main.hs -finfo-table-map
+	'$(TEST_HC)' $(TEST_HC_OPTS) Main.o test.o test2.o subdir/test.o
+
+
diff --git a/testsuite/tests/cmm/should_compile/T21370/all.T b/testsuite/tests/cmm/should_compile/T21370/all.T
new file mode 100644
index 0000000000..a88bb4d26f
--- /dev/null
+++ b/testsuite/tests/cmm/should_compile/T21370/all.T
@@ -0,0 +1 @@
+test('T21370', [extra_files(["subdir", "test.cmm", "test2.cmm", "Main.hs"])] , makefile_test, [])
diff --git a/testsuite/tests/cmm/should_compile/T21370/subdir/test.cmm b/testsuite/tests/cmm/should_compile/T21370/subdir/test.cmm
new file mode 100644
index 0000000000..95503df8af
--- /dev/null
+++ b/testsuite/tests/cmm/should_compile/T21370/subdir/test.cmm
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+test3 (W_ r1)
+ {
+    return (r1);
+ }
diff --git a/testsuite/tests/cmm/should_compile/T21370/test.cmm b/testsuite/tests/cmm/should_compile/T21370/test.cmm
new file mode 100644
index 0000000000..13e3aa3ebb
--- /dev/null
+++ b/testsuite/tests/cmm/should_compile/T21370/test.cmm
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+test (W_ r1)
+ {
+    return (r1);
+ }
diff --git a/testsuite/tests/cmm/should_compile/T21370/test2.cmm b/testsuite/tests/cmm/should_compile/T21370/test2.cmm
new file mode 100644
index 0000000000..c591feecb6
--- /dev/null
+++ b/testsuite/tests/cmm/should_compile/T21370/test2.cmm
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+test2 (W_ r1)
+ {
+    return (r1);
+ }