Add special case for :Main module in `GHC.IfaceToCore.mk_top_id`wip/t22405

See Note [Root-main Id]

The `:Main` special binding is actually defined in the current module
(hence don't go looking for it externally) but the module name is rOOT_MAIN
rather than the current module so we need this special case.

There was already some similar logic in `GHC.Rename.Env` for
External Core, but now the "External Core" is in interface files it
needs to be moved here instead.

Fixes #22405

9 files changed, 58 insertions, 1 deletions

diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 0df2dec9bc..ac18133e3c 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -123,6 +123,7 @@ import GHC.Driver.Env.KnotVars
 import GHC.Unit.Module.WholeCoreBindings
 import Data.IORef
 import Data.Foldable
+import GHC.Builtin.Names (ioTyConName, rOOT_MAIN)
 
 {-
 This module takes
@@ -930,7 +931,17 @@ tc_iface_binding i IfUseUnfoldingRhs = return (unfoldingTemplate $ realIdUnfoldi
 tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs
 
 mk_top_id :: IfaceTopBndrInfo -> IfL Id
-mk_top_id (IfGblTopBndr gbl_name) = tcIfaceExtId gbl_name
+mk_top_id (IfGblTopBndr gbl_name)
+  -- See Note [Root-main Id]
+  -- This special binding is actually defined in the current module
+  -- (hence don't go looking for it externally) but the module name is rOOT_MAIN
+  -- rather than the current module so we need this special case.
+  -- See some similar logic in `GHC.Rename.Env`.
+  | Just rOOT_MAIN == nameModule_maybe gbl_name
+    = do
+        ATyCon ioTyCon <- tcIfaceGlobal ioTyConName
+        return $ mkExportedVanillaId gbl_name (mkTyConApp ioTyCon [unitTy])
+  | otherwise = tcIfaceExtId gbl_name
 mk_top_id (IfLclTopBndr raw_name iface_type info details) = do
    name <- newIfaceName (mkVarOccFS raw_name)
    ty <- tcIfaceType iface_type
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 3d3ded48f0..90c9f38faf 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -207,6 +207,11 @@ newTopSrcBinder (L loc rdr_name)
         -- the nice Exact name for the TyCon gets swizzled to an Orig name.
         -- Hence the badOrigBinding error message.
         --
+
+        -- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore
+        -- because External Core has been removed but we instead have some similar logic for
+        -- serialising whole programs into interface files in GHC.IfaceToCore.mk_top_id.
+
         -- Except for the ":Main.main = ..." definition inserted into
         -- the Main module; ugh!
 
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 68728cd3d7..597de656b7 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2042,6 +2042,14 @@ This is unusual: it's a LocalId whose Name has a Module from another
 module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we
 get two defns for 'main' in the interface file!
 
+When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file.
+When the interface is read back in we have to add a special case when creating the
+Id because otherwise we would go looking for the :Main module which obviously doesn't
+exist. For this logic see GHC.IfaceToCore.mk_top_id.
+
+There is also some similar (probably dead) logic in GHC.Rename.Env which says it
+was added for External Core which faced a similar issue.
+
 
 *********************************************************
 *                                                       *
diff --git a/testsuite/tests/driver/fat-iface/T22405/Main.hs b/testsuite/tests/driver/fat-iface/T22405/Main.hs
new file mode 100644
index 0000000000..d82a4bd93b
--- /dev/null
+++ b/testsuite/tests/driver/fat-iface/T22405/Main.hs
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = return ()
diff --git a/testsuite/tests/driver/fat-iface/T22405/Main2.hs b/testsuite/tests/driver/fat-iface/T22405/Main2.hs
new file mode 100644
index 0000000000..f497b63315
--- /dev/null
+++ b/testsuite/tests/driver/fat-iface/T22405/Main2.hs
@@ -0,0 +1,6 @@
+module Main2 where
+
+main :: IO ()
+main = return ()
+
+
diff --git a/testsuite/tests/driver/fat-iface/T22405/Makefile b/testsuite/tests/driver/fat-iface/T22405/Makefile
new file mode 100644
index 0000000000..91d7e1231e
--- /dev/null
+++ b/testsuite/tests/driver/fat-iface/T22405/Makefile
@@ -0,0 +1,17 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RTSOPTS = $(filter-out -rtsopts,$(TEST_HC_OPTS))
+
+clean:
+	rm -f *.hi *.hi-fat *.o
+
+T22405: clean
+	"$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main
+	"$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main
+
+T22405b: clean
+	"$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main2 -main-is Main2
+	"$(TEST_HC)" $(TEST_HC_OPTS) -fbyte-code-and-object-code Main2 -main-is Main2
+
diff --git a/testsuite/tests/driver/fat-iface/T22405/T22405.stdout b/testsuite/tests/driver/fat-iface/T22405/T22405.stdout
new file mode 100644
index 0000000000..9417491f3d
--- /dev/null
+++ b/testsuite/tests/driver/fat-iface/T22405/T22405.stdout
@@ -0,0 +1,2 @@
+[1 of 2] Compiling Main             ( Main.hs, Main.o, interpreted )
+[2 of 2] Linking Main
diff --git a/testsuite/tests/driver/fat-iface/T22405/T22405b.stdout b/testsuite/tests/driver/fat-iface/T22405/T22405b.stdout
new file mode 100644
index 0000000000..f88f60dc5d
--- /dev/null
+++ b/testsuite/tests/driver/fat-iface/T22405/T22405b.stdout
@@ -0,0 +1,2 @@
+[1 of 2] Compiling Main2            ( Main2.hs, Main2.o, interpreted )
+[2 of 2] Linking Main2
diff --git a/testsuite/tests/driver/fat-iface/T22405/all.T b/testsuite/tests/driver/fat-iface/T22405/all.T
new file mode 100644
index 0000000000..d54b27fac1
--- /dev/null
+++ b/testsuite/tests/driver/fat-iface/T22405/all.T
@@ -0,0 +1,2 @@
+test('T22405', [extra_files(['Main.hs'])], makefile_test, ['T22405'])
+test('T22405b', [extra_files(['Main2.hs'])], makefile_test, ['T22405b'])