testsuite: Add T20494

5 files changed, 92 insertions, 0 deletions

diff --git a/testsuite/tests/rts/linker/Makefile b/testsuite/tests/rts/linker/Makefile
index 3c78908d5d..bbfd067f30 100644
--- a/testsuite/tests/rts/linker/Makefile
+++ b/testsuite/tests/rts/linker/Makefile
@@ -120,6 +120,12 @@ T7072:
 	"$(TEST_HC)" T7072-main.c -o T7072-main -no-hs-main -debug
 	./T7072-main T7072-obj.o
 
+.PHONY: T20494
+T20494:
+	"$(TEST_HC)" $(TEST_HC_OPTS) -c T20494-obj.c -o T20494-obj.o
+	"$(TEST_HC)" -v0 T20494.hs
+	./T20494 T20494-obj.o
+
 .PHONY: T20918
 T20918:
 	"$(TEST_HC)" -c T20918_v.cc -o T20918_v.o
diff --git a/testsuite/tests/rts/linker/T20494-obj.c b/testsuite/tests/rts/linker/T20494-obj.c
new file mode 100644
index 0000000000..ed073d6cfa
--- /dev/null
+++ b/testsuite/tests/rts/linker/T20494-obj.c
@@ -0,0 +1,14 @@
+#include <stdio.h>
+
+#define CONSTRUCTOR(prio) __attribute__((constructor(prio)))
+#define DESTRUCTOR(prio)  __attribute__((destructor(prio)))
+#define PRINT(str) printf(str); fflush(stdout)
+
+CONSTRUCTOR(1000) void constr_a(void) { PRINT("constr a\n"); }
+CONSTRUCTOR(2000) void constr_b(void) { PRINT("constr b\n"); }
+DESTRUCTOR(2000)  void destr_b(void)  { PRINT("destr b\n"); }
+DESTRUCTOR(1000)  void destr_a(void)  { PRINT("destr a\n"); }
+
+void hello() {
+    PRINT("hello\n");
+}
diff --git a/testsuite/tests/rts/linker/T20494.hs b/testsuite/tests/rts/linker/T20494.hs
new file mode 100644
index 0000000000..dc5b68eeac
--- /dev/null
+++ b/testsuite/tests/rts/linker/T20494.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE ForeignFunctionInterface, CPP #-}
+import Foreign.C.String
+import Control.Monad
+import System.Environment
+import System.FilePath
+import Foreign.Ptr
+import System.Mem
+
+-- Type of paths is different on Windows
+#if defined(mingw32_HOST_OS)
+type PathString = CWString
+withPathString = withCWString
+#else
+type PathString = CString
+withPathString = withCString
+#endif
+
+-- | All symbols begin with an underscore on Darwin
+withUnderscore :: String -> String
+#if defined(darwin_HOST_OS)
+withUnderscore = ("_" ++)
+#else
+withUnderscore = id
+#endif
+
+foreign import ccall "initLinker"
+    initLinker :: IO ()
+foreign import ccall "loadObj"
+    loadObj :: PathString -> IO Int
+foreign import ccall "resolveObjs"
+    resolveObjs :: IO Int
+foreign import ccall "lookupSymbol"
+    lookupSymbol :: CString -> IO (FunPtr a)
+foreign import ccall "unloadObj"
+    unloadObj :: PathString -> IO Int
+
+type HelloFn = IO ()
+foreign import ccall "dynamic"
+  mkHello :: FunPtr HelloFn -> HelloFn
+
+main :: IO ()
+main = do
+    [objPath] <- getArgs
+    initLinker
+
+    r <- withPathString objPath loadObj
+    when (r /= 1) $ error "loadObj failed"
+
+    r <- resolveObjs
+    when (r /= 1) $ error "resolveObj failed"
+
+    ptr <- withCString (withUnderscore "hello") lookupSymbol
+    when (nullFunPtr == ptr) $ error "lookupSymbol failed"
+
+    let hello = mkHello ptr
+    hello
+
+    withPathString objPath unloadObj
+    when (r /= 1) $ error "unloadObj failed"
+
+    -- Perform a major GC to ensure that the object can be unloaded.
+    performMajorGC
\ No newline at end of file
diff --git a/testsuite/tests/rts/linker/T20494.stdout b/testsuite/tests/rts/linker/T20494.stdout
new file mode 100644
index 0000000000..d80bddc350
--- /dev/null
+++ b/testsuite/tests/rts/linker/T20494.stdout
@@ -0,0 +1,5 @@
+constr a
+constr b
+hello
+destr b
+destr a
diff --git a/testsuite/tests/rts/linker/all.T b/testsuite/tests/rts/linker/all.T
index 0cb93370aa..b7a9eda203 100644
--- a/testsuite/tests/rts/linker/all.T
+++ b/testsuite/tests/rts/linker/all.T
@@ -118,6 +118,11 @@ test('T7072',
 		req_rts_linker], 
 	makefile_test, ['T7072'])
 
+test('T20494',
+     [req_rts_linker,
+      # The PEi386 linker doesn't yet support finalizers
+      when(opsys('mingw32'), expect_broken(20494))],
+    makefile_test, ['T20494'])
 
 test('T20918',
      [extra_files(['T20918_v.cc']),