Don't build extra object with -no-hs-main

We don't need to compile/link an additional empty C file when it is not
needed.

This patch may also fix #18938 by avoiding trying to lookup the RTS unit
when there is none (yet) in the unit database.

2 files changed, 25 insertions, 12 deletions

diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs
index 8e95f62d84..b8dca3e8dc 100644
--- a/compiler/GHC/Linker/ExtraObj.hs
+++ b/compiler/GHC/Linker/ExtraObj.hs
@@ -87,23 +87,34 @@ mkExtraObj logger dflags unit_state extn xs
 --
 -- On Windows, when making a shared library we also may need a DllMain.
 --
-mkExtraObjToLinkIntoBinary :: Logger -> DynFlags -> UnitState -> IO FilePath
+mkExtraObjToLinkIntoBinary :: Logger -> DynFlags -> UnitState -> IO (Maybe FilePath)
 mkExtraObjToLinkIntoBinary logger dflags unit_state = do
   when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $
      logInfo logger dflags $ withPprStyle defaultUserStyle
          (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
           text "    Call hs_init_ghc() from your main() function to set these options.")
 
-  mkExtraObj logger dflags unit_state "c" (showSDoc dflags main)
-  where
-    main
-      | gopt Opt_NoHsMain dflags = Outputable.empty
+  case ghcLink dflags of
+    -- Don't try to build the extra object if it is not needed.  Compiling the
+    -- extra object assumes the presence of the RTS in the unit database
+    -- (because the extra object imports Rts.h) but GHC's build system may try
+    -- to build some helper programs before building and registering the RTS!
+    -- See #18938 for an example where hp2ps failed to build because of a failed
+    -- (unsafe) lookup for the RTS in the unit db.
+    _ | gopt Opt_NoHsMain dflags
+      -> return Nothing
+
+    LinkDynLib
+      | OSMinGW32 <- platformOS (targetPlatform dflags)
+      -> mk_extra_obj dllMain
+
       | otherwise
-          = case ghcLink dflags of
-                  LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32
-                                    then dllMain
-                                    else Outputable.empty
-                  _                      -> exeMain
+      -> return Nothing
+
+    _ -> mk_extra_obj exeMain
+
+  where
+    mk_extra_obj = fmap Just . mkExtraObj logger dflags unit_state "c" . showSDoc dflags
 
     exeMain = vcat [
         text "#include <Rts.h>",
diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs
index 84fbe41e7e..32640ddf62 100644
--- a/compiler/GHC/Linker/Static.hs
+++ b/compiler/GHC/Linker/Static.hs
@@ -35,6 +35,7 @@ import GHC.Driver.Session
 import System.FilePath
 import System.Directory
 import Control.Monad
+import Data.Maybe
 
 -----------------------------------------------------------------------------
 -- Static linking, of .o files
@@ -137,7 +138,7 @@ linkBinary' staticLink logger dflags unit_env o_files dep_units = do
     let lib_paths = libraryPaths dflags
     let lib_path_opts = map ("-L"++) lib_paths
 
-    extraLinkObj <- mkExtraObjToLinkIntoBinary logger dflags unit_state
+    extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger dflags unit_state
     noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_units
 
     let
@@ -253,7 +254,8 @@ linkBinary' staticLink logger dflags unit_env o_files dep_units = do
                          rc_objs
                       ++ framework_opts
                       ++ pkg_lib_path_opts
-                      ++ extraLinkObj:noteLinkObjs
+                      ++ extraLinkObj
+                      ++ noteLinkObjs
                       ++ pkg_link_opts
                       ++ pkg_framework_opts
                       ++ (if platformOS platform == OSDarwin