[Git][ghc/ghc][wip/T13786] 2 commits: testsuite: Test for #13786
Ben Gamari
gitlab at gitlab.haskell.org
Fri Jun 14 21:47:28 UTC 2019
Ben Gamari pushed to branch wip/T13786 at Glasgow Haskell Compiler / GHC
Commits:
7e23bbf8 by Ben Gamari at 2019-06-14T21:47:19Z
testsuite: Test for #13786
- - - - -
162036ab by Ben Gamari at 2019-06-14T21:47:19Z
ghci: Load static objects in batches
Fixes #13786.
- - - - -
7 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/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
@@ -1139,7 +1154,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.
@@ -1173,7 +1190,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
@@ -1270,7 +1287,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
@@ -1478,8 +1496,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,3 @@
+T13786 :
+ $(TEST_HC) -c -fPIC T13786a.c T13786b.c
+ $(TEST_HC_INTERACTIVE) T13786a.o T13786b.o T13786.hs < T13786.script
=====================================
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/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/6e126313818665743f9516c7b8fa1f400197b0ea...162036aba5d69ac855a60488cfe8475cae4278ac
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/6e126313818665743f9516c7b8fa1f400197b0ea...162036aba5d69ac855a60488cfe8475cae4278ac
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/20190614/8c441325/attachment-0001.html>
More information about the ghc-commits
mailing list