[Git][ghc/ghc][master] 2 commits: testsuite: Test for #13786
Marge Bot
gitlab at gitlab.haskell.org
Sun Jun 23 21:19:54 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ade3db53 by Ben Gamari at 2019-06-23T21:19:48Z
testsuite: Test for #13786
- - - - -
5a502cd1 by Ben Gamari at 2019-06-23T21:19:48Z
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.
- - - - -
8 changed files:
- compiler/ghci/Linker.hs
- + testsuite/tests/ghci/T13786/Makefile
- + testsuite/tests/ghci/T13786/T13786.hs
- + testsuite/tests/ghci/T13786/T13786.script
- + testsuite/tests/ghci/T13786/T13786.stdout
- + testsuite/tests/ghci/T13786/T13786a.c
- + testsuite/tests/ghci/T13786/T13786b.c
- + testsuite/tests/ghci/T13786/all.T
Changes:
=====================================
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 at 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
=====================================
testsuite/tests/ghci/T13786/Makefile
=====================================
@@ -0,0 +1,9 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: T13786
+T13786 :
+ "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c -fPIC T13786a.c
+ "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c -fPIC T13786b.c
+ cat T13786.script | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -v0 T13786a.o T13786b.o T13786.hs
=====================================
testsuite/tests/ghci/T13786/T13786.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+foreign import ccall unsafe "hello_a" helloA :: IO ()
+
=====================================
testsuite/tests/ghci/T13786/T13786.script
=====================================
@@ -0,0 +1 @@
+helloA
=====================================
testsuite/tests/ghci/T13786/T13786.stdout
=====================================
@@ -0,0 +1,4 @@
+hello world A
+hello world B
+hello world A
+
=====================================
testsuite/tests/ghci/T13786/T13786a.c
=====================================
@@ -0,0 +1,15 @@
+#include <stdio.h>
+#include <stdbool.h>
+
+static bool flag_a = false;
+
+extern void hello_b();
+
+void hello_a() {
+ if (! flag_a) {
+ flag_a = true;
+ hello_b();
+ }
+
+ printf("hello world A\n");
+}
=====================================
testsuite/tests/ghci/T13786/T13786b.c
=====================================
@@ -0,0 +1,16 @@
+#include <stdio.h>
+#include <stdbool.h>
+
+static bool flag_b = false;
+
+extern void hello_a();
+
+void hello_b() {
+ if (! flag_b) {
+ flag_b = true;
+ hello_a();
+ }
+
+ printf("hello world B\n");
+}
+
=====================================
testsuite/tests/ghci/T13786/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T13786', normal, makefile_test, [])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/1f2fff89afebb065b27eba0f6e1f89e25c1c158d...5a502cd1431b535a12dced0479b75c5f7dbfb01c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/1f2fff89afebb065b27eba0f6e1f89e25c1c158d...5a502cd1431b535a12dced0479b75c5f7dbfb01c
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/20190623/9e03f260/attachment-0001.html>
More information about the ghc-commits
mailing list