ghci: Load static objects in batches

Previously in the case where GHC was dynamically linked we would load
static objects one-by-one by linking each into its own shared object and
dlopen'ing each in order. However, this meant that the link would fail
in the event that the objects had cyclic symbol dependencies.

Here we fix this by merging each "run" of static objects into a single
shared object and loading this.

Fixes #13786 for the case where GHC is dynamically linked.

1 files changed, 31 insertions, 13 deletions

diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index c77ca5c5e6..910715e594 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -352,8 +352,10 @@ linkCmdLineLibs' hsc_env pls =
       all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
       pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
 
+      let merged_specs = mergeStaticObjects cmdline_lib_specs
       pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
-                    cmdline_lib_specs
+                    merged_specs
+
       maybePutStr dflags "final link ... "
       ok <- resolveObjs hsc_env
 
@@ -365,6 +367,19 @@ linkCmdLineLibs' hsc_env pls =
 
       return pls1
 
+-- | Merge runs of consecutive of 'Objects'. This allows for resolution of
+-- cyclic symbol references when dynamically linking. Specifically, we link
+-- together all of the static objects into a single shared object, avoiding
+-- the issue we saw in #13786.
+mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]
+mergeStaticObjects specs = go [] specs
+  where
+    go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]
+    go accum (Objects objs : rest) = go (objs ++ accum) rest
+    go accum@(_:_) rest = Objects (reverse accum) : go [] rest
+    go [] (spec:rest) = spec : go [] rest
+    go [] [] = []
+
 {- Note [preload packages]
 
 Why do we need to preload packages from the command line?  This is an
@@ -392,7 +407,7 @@ users?
 
 classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
 classifyLdInput dflags f
-  | isObjectFilename platform f = return (Just (Object f))
+  | isObjectFilename platform f = return (Just (Objects [f]))
   | isDynLibFilename platform f = return (Just (DLLPath f))
   | otherwise          = do
         putLogMsg dflags NoReason SevInfo noSrcSpan
@@ -407,8 +422,8 @@ preloadLib
 preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
   maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
   case lib_spec of
-    Object static_ish -> do
-      (b, pls1) <- preload_static lib_paths static_ish
+    Objects static_ishs -> do
+      (b, pls1) <- preload_statics lib_paths static_ishs
       maybePutStrLn dflags (if b  then "done" else "not found")
       return pls1
 
@@ -467,13 +482,13 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
                         intercalate "\n" (map ("   "++) paths)))
 
     -- Not interested in the paths in the static case.
-    preload_static _paths name
-       = do b <- doesFileExist name
+    preload_statics _paths names
+       = do b <- or <$> mapM doesFileExist names
             if not b then return (False, pls)
                      else if dynamicGhc
-                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
+                             then  do pls1 <- dynLoadObjs hsc_env pls names
                                       return (True, pls1)
-                             else  do loadObj hsc_env name
+                             else  do mapM_ (loadObj hsc_env) names
                                       return (True, pls)
 
     preload_static_archive _paths name
@@ -1143,7 +1158,9 @@ unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..}  = do
   ********************************************************************* -}
 
 data LibrarySpec
-   = Object FilePath    -- Full path name of a .o file, including trailing .o
+   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o
+                        -- We allow batched loading to ensure that cyclic symbol
+                        -- references can be resolved (see #13786).
                         -- For dynamic objects only, try to find the object
                         -- file in all the directories specified in
                         -- v_Library_paths before giving up.
@@ -1177,7 +1194,7 @@ partOfGHCi
                    ["base", "template-haskell", "editline"]
 
 showLS :: LibrarySpec -> String
-showLS (Object nm)    = "(static) " ++ nm
+showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]"
 showLS (Archive nm)   = "(static archive) " ++ nm
 showLS (DLL nm)       = "(dynamic) " ++ nm
 showLS (DLLPath nm)   = "(dynamic) " ++ nm
@@ -1274,7 +1291,8 @@ linkPackage hsc_env pkg
         -- Complication: all the .so's must be loaded before any of the .o's.
         let known_dlls = [ dll  | DLLPath dll    <- classifieds ]
             dlls       = [ dll  | DLL dll        <- classifieds ]
-            objs       = [ obj  | Object obj     <- classifieds ]
+            objs       = [ obj  | Objects objs    <- classifieds
+                                , obj <- objs ]
             archs      = [ arch | Archive arch   <- classifieds ]
 
         -- Add directories to library search paths
@@ -1482,8 +1500,8 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
                              (ArchX86_64, OSSolaris2) -> "64" </> so_name
                              _ -> so_name
 
-     findObject    = liftM (fmap Object)  $ findFile dirs obj_file
-     findDynObject = liftM (fmap Object)  $ findFile dirs dyn_obj_file
+     findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file
+     findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file
      findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name
                      in  apply (map local arch_files)
      findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file