Commit 6108d95a authored by Simon Marlow's avatar Simon Marlow Committed by Simon Marlow

Make the linker_unload test less fragile

Summary:
Now it invokes the GHC API to load packages, rather than trying to do it
manually.  This should fix most of the issues we've had with this test,
and might make it work on Windows too.
parent 9894f6a5
module LinkerUnload (init) where
import GHC
import DynFlags
import Linker
import System.Environment
import MonadUtils ( MonadIO(..) )
foreign export ccall loadPackages :: IO ()
loadPackages :: IO ()
loadPackages = do
[libdir] <- getArgs
runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
let dflags' = dflags { hscTarget = HscNothing
, ghcLink = LinkInMemory }
pkgs <- setSessionDynFlags dflags'
dflags <- getSessionDynFlags
liftIO $ Linker.linkPackages dflags pkgs
......@@ -102,30 +102,13 @@ T7037:
T7040_ghci_setup :
'$(TEST_HC)' $(TEST_HC_OPTS) $(ghciWayFlags) -c T7040_ghci_c.c
LOCAL_GHC_PKG = '$(GHC_PKG)' --no-user-package-db
BASE_DIR = $(shell $(LOCAL_GHC_PKG) field base library-dirs | sed 's/^[^:]*: *//')
BASE_LIB = $(shell $(LOCAL_GHC_PKG) field base hs-libraries | sed 's/^[^:]*: *//')
GHC_PRIM_DIR = $(shell $(LOCAL_GHC_PKG) field ghc-prim library-dirs | sed 's/^[^:]*: *//')
GHC_PRIM_LIB = $(shell $(LOCAL_GHC_PKG) field ghc-prim hs-libraries | sed 's/^[^:]*: *//')
# We need to get first library directory here in order to get rid of
# system gmp library directory installation when ghc is configured
# with --with-gmp-libraries=<dir> parameter
INTEGER_GMP_DIR = $(shell $(LOCAL_GHC_PKG) field integer-gmp library-dirs \
| sed 's/^[^:]*: *//' | head -1)
INTEGER_GMP_LIB = $(shell $(LOCAL_GHC_PKG) field integer-gmp hs-libraries | sed 's/^.*: *//')
BASE = $(BASE_DIR)/lib$(BASE_LIB).a
GHC_PRIM = $(GHC_PRIM_DIR)/lib$(GHC_PRIM_LIB).a
INTEGER_GMP = $(INTEGER_GMP_DIR)/lib$(INTEGER_GMP_LIB).a
.PHONY: linker_unload
linker_unload:
$(RM) Test.o Test.hi
"$(TEST_HC)" $(TEST_HC_OPTS) -c Test.hs -v0
# -rtsopts causes a warning
"$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) linker_unload.c -o linker_unload -no-hs-main -optc-Werror -threaded
./linker_unload $(BASE) $(GHC_PRIM) $(INTEGER_GMP)
"$(TEST_HC)" LinkerUnload.hs -package ghc $(filter-out -rtsopts, $(TEST_HC_OPTS)) linker_unload.c -o linker_unload -no-hs-main -optc-Werror
./linker_unload "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
# -----------------------------------------------------------------------------
# Testing failures in the RTS linker. We should be able to repeatedly
......
......@@ -2,11 +2,10 @@
#include <stdio.h>
#include <stdlib.h>
#include "Rts.h"
#if defined(mingw32_HOST_OS)
#include <malloc.h>
#endif
#include <string.h>
#define ITERATIONS 10000
#define ITERATIONS 1000
#if defined(mingw32_HOST_OS)
#define OBJPATH L"Test.o"
......@@ -16,16 +15,7 @@
typedef int testfun(int);
void loadPkg(pathchar *path)
{
int r;
r = loadArchive(path);
if (!r) {
errorBelch("loadObjs(%s) failed", path);
exit(1);
}
}
extern void loadPackages(void);
int main (int argc, char *argv[])
{
......@@ -38,24 +28,7 @@ int main (int argc, char *argv[])
initLinker_(0);
for (i=1; i < argc; i++) {
#if defined(mingw32_HOST_OS)
size_t len = mbstowcs(NULL, argv[i], 0) + 1;
if (len == -1) {
errorBelch("invalid multibyte sequence in argument %d: %s", i, argv[i]);
exit(1);
}
wchar_t *buf = (wchar_t*)_alloca(len * sizeof(wchar_t));
size_t len2 = mbstowcs(buf, argv[i], len);
if (len != len2 + 1) {
errorBelch("something fishy is going on in argument %d: %s", i, argv[i]);
exit(1);
}
loadPkg(buf);
#else
loadPkg(argv[i]);
#endif
}
loadPackages();
for (i=0; i < ITERATIONS; i++) {
r = loadObj(OBJPATH);
......
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment