[Git][ghc/ghc][ghc-8.8] 11 commits: Add `-haddock` option under ci condition to fix #16415
Ben Gamari
gitlab at gitlab.haskell.org
Thu Jun 13 23:33:07 UTC 2019
Ben Gamari pushed to branch ghc-8.8 at Glasgow Haskell Compiler / GHC
Commits:
c4b501b1 by Takenobu Tani at 2019-06-12T12:39:41Z
Add `-haddock` option under ci condition to fix #16415
In order to use the `:doc` command in ghci, it is necessary
to compile for core libraries with `-haddock` option.
Especially, the `-haddock` option is essential for release building.
Note:
* The `-haddock` option may affect compile time and binary size.
* But hadrian has already set `-haddock` as the default.
* This patch affects the make-based building.
This patch has been split from !532.
(cherry picked from commit 33e37d0619a9d1d0b8088a109f7eeb4c6fd21027)
- - - - -
b51f9ecd by Takenobu Tani at 2019-06-12T12:39:41Z
Add `-haddock` to perf.mk rather than prepare-system.sh
To cover ci conditions from ghc8.6 to 8.9, I add `-haddock` option
to `mk/flavours/perf.mk` rather than `.circleci/prepare-system.sh`.
Because in windows condition of ghc-8.9, `mk/flavours/*` is included
after `prepare-system.sh`.
In addition, in linux condition of ghc-8.6, `mk/flavors/perf.mk` is used.
(cherry picked from commit 43a39c3c2195d5b4400efc845a54f153184b1d7f)
- - - - -
ca7173a9 by Takenobu Tani at 2019-06-12T12:39:41Z
Add `-haddock` to prepare-system.sh and .gitlab-ci.yml
To cover ci conditions from ghc8.6 to 8.9, I add `-haddock` option
to `.circleci/prepare-system.sh` and .gitlab-ci.yml.
after including `mk/flavours/*`.
(cherry picked from commit c4f94320a7048a7f263d8d952d4e12cc0227cf72)
- - - - -
ce1e6538 by Phuong Trinh at 2019-06-12T12:40:33Z
Use binary search to speedup checkUnload
We are iterating through all object code for each heap objects when
checking whether object code can be unloaded. For large projects in
GHCi, this can be very expensive due to the large number of object code
that needs to be loaded/unloaded. To speed it up, this arrangess all
mapped sections of unloaded object code in a sorted array and use binary
search to check if an address location fall on them.
(cherry picked from commit f81f3964b718eab21f0cfe65067c195f2f2a84bd)
- - - - -
e628c7be by Ben Gamari at 2019-06-12T12:45:15Z
rts/linker: Make elf_got.c a bit more legible
(cherry picked from commit bbc752c50f3adcb659cd8447635828e137a0a314)
- - - - -
2e8be92b by Ben Gamari at 2019-06-12T12:45:15Z
rts/linker: Only mprotect GOT after it is filled
This fixes a regression, introduced by 67c422ca, where we mprotect'd the
global offset table (GOT) region to PROT_READ before we had finished
filling it, resulting in a linker crash.
Fixes #16779.
(cherry picked from commit 217e6db4af6752b13c586d4e8925a4a9a2f47245)
- - - - -
ba667f6b by Ben Gamari at 2019-06-12T12:46:46Z
llvm-targets: Add armv7l-unknown-linux-gnueabi
Fixes #15208.
[skip ci]
(cherry picked from commit 9b4ff57d71eebf6dd71a5d81d0f9c9c2aef80e65)
- - - - -
8c862c07 by Ben Gamari at 2019-06-12T12:47:52Z
rts/linker: Use mmapForLinker to map PLT
The PLT needs to be located within a close distance of
the code calling it under the small memory model.
Fixes #16784.
(cherry picked from commit 0b7f81f560c602f32cfc90fd3fb5f1c52f06ad49)
- - - - -
b4c1cf55 by Ben Gamari at 2019-06-13T14:49:40Z
Bump process submodule to 1.6.5.1
- - - - -
eeca442c by Ben Gamari at 2019-06-13T14:51:12Z
Merge branches 'wip/backport-MR1137', 'wip/backport-MR1139', 'wip/backport-MR1160', 'wip/backport-MR706' and 'wip/backport-MR769' into wip/ghc-8.8-merges
- - - - -
e9d603ef by Ben Gamari at 2019-06-13T16:30:38Z
Add dwarf flavour definition
- - - - -
17 changed files:
- .circleci/prepare-system.sh
- .gitlab-ci.yml
- libraries/process
- llvm-targets
- + mk/flavours/dwarf.mk
- rts/CheckUnload.c
- rts/linker/Elf.c
- rts/linker/elf_got.c
- + testsuite/tests/rts/unload_multiple_objs/A.hs
- + testsuite/tests/rts/unload_multiple_objs/B.hs
- + testsuite/tests/rts/unload_multiple_objs/C.hs
- + testsuite/tests/rts/unload_multiple_objs/D.hs
- + testsuite/tests/rts/unload_multiple_objs/Makefile
- + testsuite/tests/rts/unload_multiple_objs/all.T
- + testsuite/tests/rts/unload_multiple_objs/linker_unload_multiple_objs.c
- + testsuite/tests/rts/unload_multiple_objs/linker_unload_multiple_objs.stdout
- utils/llvm-targets/gen-data-layout.sh
Changes:
=====================================
.circleci/prepare-system.sh
=====================================
@@ -30,6 +30,7 @@ BuildFlavour=$BUILD_FLAVOUR
ifneq "\$(BuildFlavour)" ""
include mk/flavours/\$(BuildFlavour).mk
endif
+GhcLibHcOpts+=-haddock
EOF
case "$(uname)" in
=====================================
.gitlab-ci.yml
=====================================
@@ -563,6 +563,7 @@ nightly-i386-windows-hadrian:
python boot
bash -c './configure --enable-tarballs-autodownload GHC=`pwd`/toolchain/bin/ghc HAPPY=`pwd`/toolchain/bin/happy ALEX=`pwd`/toolchain/bin/alex $CONFIGURE_ARGS'
- bash -c "echo include mk/flavours/${BUILD_FLAVOUR}.mk > mk/build.mk"
+ - bash -c "echo 'GhcLibHcOpts+=-haddock' >> mk/build.mk"
- bash -c "PATH=`pwd`/toolchain/bin:$PATH make -j`mk/detect-cpu-count.sh`"
- bash -c "PATH=`pwd`/toolchain/bin:$PATH make binary-dist TAR_COMP_OPTS=-1"
- bash -c 'make V=0 test THREADS=`mk/detect-cpu-count.sh` JUNIT_FILE=../../junit.xml'
=====================================
libraries/process
=====================================
@@ -1 +1 @@
-Subproject commit d860209e53c1b40b7c251fc8378886bbcb394402
+Subproject commit 09446a522f5c8ec5a5c32c7494bc1704e107776e
=====================================
llvm-targets
=====================================
@@ -7,6 +7,7 @@
,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
=====================================
mk/flavours/dwarf.mk
=====================================
@@ -0,0 +1,14 @@
+# Build flavour which produces a compiler, RTS, and core libraries with DWARF
+# debug information. For best results run ./configure with
+# --enable-dwarf-unwind.
+
+SRC_HC_OPTS = -O -H64m
+GhcStage1HcOpts = -O2
+GhcStage2HcOpts = -O2 -g3
+GhcRtsHcOpts = -O2 -g3
+GhcLibHcOpts = -O2 -g3
+BUILD_PROF_LIBS = YES
+#SplitObjs
+#HADDOCK_DOCS
+#BUILD_SPHINX_HTML
+#BUILD_SPHINX_PDF
=====================================
rts/CheckUnload.c
=====================================
@@ -38,30 +38,130 @@
// object as referenced so that it won't get unloaded in this round.
//
-static void checkAddress (HashTable *addrs, const void *addr)
+// Note [Speeding up checkUnload]
+// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+// In certain circumstances, there may be a lot of unloaded ObjectCode structs
+// chained in `unloaded_objects` (such as when users `:load` a module in a very
+// big repo in GHCi). To speed up checking whether an address lies within any of
+// these objects, we populate the addresses of their mapped sections in
+// an array sorted by their `start` address and do binary search for our address
+// on that array. Note that this works because the sections are mapped to mutual
+// exclusive memory regions, so we can simply find the largest lower bound among
+// the `start` addresses of the sections and then check if our address is inside
+// that section. In particular, we store the start address and end address of
+// each mapped section in a OCSectionIndex, arrange them all on a contiguous
+// memory range and then sort by start address. We then put this array in an
+// OCSectionIndices struct to be passed into `checkAddress` to do binary search
+// on.
+//
+
+typedef struct {
+ W_ start;
+ W_ end;
+ ObjectCode *oc;
+} OCSectionIndex;
+
+typedef struct {
+ int n_sections;
+ OCSectionIndex *indices;
+} OCSectionIndices;
+
+static OCSectionIndices *createOCSectionIndices(int n_sections)
+{
+ OCSectionIndices *s_indices;
+ s_indices = stgMallocBytes(sizeof(OCSectionIndices), "OCSectionIndices");
+ s_indices->n_sections = n_sections;
+ s_indices->indices = stgMallocBytes(n_sections*sizeof(OCSectionIndex),
+ "OCSectionIndices::indices");
+ return s_indices;
+}
+
+static int cmpSectionIndex(const void* indexa, const void *indexb)
+{
+ W_ s1 = ((OCSectionIndex*)indexa)->start;
+ W_ s2 = ((OCSectionIndex*)indexb)->start;
+ if (s1 < s2) {
+ return -1;
+ } else if (s1 > s2) {
+ return 1;
+ }
+ return 0;
+}
+
+static OCSectionIndices* buildOCSectionIndices(ObjectCode *ocs)
+{
+ int cnt_sections = 0;
+ ObjectCode *oc;
+ for (oc = ocs; oc; oc = oc->next) {
+ cnt_sections += oc->n_sections;
+ }
+ OCSectionIndices* s_indices = createOCSectionIndices(cnt_sections);
+ int s_i = 0, i;
+ for (oc = ocs; oc; oc = oc->next) {
+ for (i = 0; i < oc->n_sections; i++) {
+ if (oc->sections[i].kind != SECTIONKIND_OTHER) {
+ s_indices->indices[s_i].start = (W_)oc->sections[i].start;
+ s_indices->indices[s_i].end = (W_)oc->sections[i].start
+ + oc->sections[i].size;
+ s_indices->indices[s_i].oc = oc;
+ s_i++;
+ }
+ }
+ }
+ s_indices->n_sections = s_i;
+ qsort(s_indices->indices,
+ s_indices->n_sections,
+ sizeof(OCSectionIndex),
+ cmpSectionIndex);
+ return s_indices;
+}
+
+static void freeOCSectionIndices(OCSectionIndices *section_indices)
+{
+ free(section_indices->indices);
+ free(section_indices);
+}
+
+static ObjectCode *findOC(OCSectionIndices *s_indices, const void *addr) {
+ W_ w_addr = (W_)addr;
+ if (s_indices->n_sections <= 0) return NULL;
+ if (w_addr < s_indices->indices[0].start) return NULL;
+
+ int left = 0, right = s_indices->n_sections;
+ while (left + 1 < right) {
+ int mid = (left + right)/2;
+ W_ w_mid = s_indices->indices[mid].start;
+ if (w_mid <= w_addr) {
+ left = mid;
+ } else {
+ right = mid;
+ }
+ }
+ ASSERT(w_addr >= s_indices->indices[left].start);
+ if (w_addr < s_indices->indices[left].end) {
+ return s_indices->indices[left].oc;
+ }
+ return NULL;
+}
+
+static void checkAddress (HashTable *addrs, const void *addr,
+ OCSectionIndices *s_indices)
{
ObjectCode *oc;
- int i;
if (!lookupHashTable(addrs, (W_)addr)) {
insertHashTable(addrs, (W_)addr, addr);
- for (oc = unloaded_objects; oc; oc = oc->next) {
- for (i = 0; i < oc->n_sections; i++) {
- if (oc->sections[i].kind != SECTIONKIND_OTHER) {
- if ((W_)addr >= (W_)oc->sections[i].start &&
- (W_)addr < (W_)oc->sections[i].start
- + oc->sections[i].size) {
- oc->referenced = 1;
- return;
- }
- }
- }
+ oc = findOC(s_indices, addr);
+ if (oc != NULL) {
+ oc->referenced = 1;
+ return;
}
}
}
-static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end)
+static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end,
+ OCSectionIndices *s_indices)
{
StgPtr p;
const StgRetInfoTable *info;
@@ -73,7 +173,7 @@ static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end)
switch (info->i.type) {
case RET_SMALL:
case RET_BIG:
- checkAddress(addrs, (const void*)info);
+ checkAddress(addrs, (const void*)info, s_indices);
break;
default:
@@ -85,7 +185,8 @@ static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end)
}
-static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
+static void searchHeapBlocks (HashTable *addrs, bdescr *bd,
+ OCSectionIndices *s_indices)
{
StgPtr p;
const StgInfoTable *info;
@@ -189,7 +290,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
prim = true;
size = ap_stack_sizeW(ap);
searchStackChunk(addrs, (StgPtr)ap->payload,
- (StgPtr)ap->payload + ap->size);
+ (StgPtr)ap->payload + ap->size, s_indices);
break;
}
@@ -223,7 +324,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
StgStack *stack = (StgStack*)p;
prim = true;
searchStackChunk(addrs, stack->sp,
- stack->stack + stack->stack_size);
+ stack->stack + stack->stack_size, s_indices);
size = stack_sizeW(stack);
break;
}
@@ -238,7 +339,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
}
if (!prim) {
- checkAddress(addrs,info);
+ checkAddress(addrs,info, s_indices);
}
p += size;
@@ -251,15 +352,16 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
// Do not unload the object if the CCS tree refers to a CCS or CC which
// originates in the object.
//
-static void searchCostCentres (HashTable *addrs, CostCentreStack *ccs)
+static void searchCostCentres (HashTable *addrs, CostCentreStack *ccs,
+ OCSectionIndices* s_indices)
{
IndexTable *i;
- checkAddress(addrs, ccs);
- checkAddress(addrs, ccs->cc);
+ checkAddress(addrs, ccs, s_indices);
+ checkAddress(addrs, ccs->cc, s_indices);
for (i = ccs->indexTable; i != NULL; i = i->next) {
if (!i->back_edge) {
- searchCostCentres(addrs, i->ccs);
+ searchCostCentres(addrs, i->ccs, s_indices);
}
}
}
@@ -288,6 +390,7 @@ void checkUnload (StgClosure *static_objects)
ACQUIRE_LOCK(&linker_unloaded_mutex);
+ OCSectionIndices *s_indices = buildOCSectionIndices(unloaded_objects);
// Mark every unloadable object as unreferenced initially
for (oc = unloaded_objects; oc; oc = oc->next) {
IF_DEBUG(linker, debugBelch("Checking whether to unload %" PATH_FMT "\n",
@@ -299,7 +402,7 @@ void checkUnload (StgClosure *static_objects)
for (p = static_objects; p != END_OF_STATIC_OBJECT_LIST; p = link) {
p = UNTAG_STATIC_LIST_PTR(p);
- checkAddress(addrs, p);
+ checkAddress(addrs, p, s_indices);
info = get_itbl(p);
link = *STATIC_LINK(info, p);
}
@@ -309,32 +412,33 @@ void checkUnload (StgClosure *static_objects)
p != END_OF_CAF_LIST;
p = ((StgIndStatic *)p)->static_link) {
p = UNTAG_STATIC_LIST_PTR(p);
- checkAddress(addrs, p);
+ checkAddress(addrs, p, s_indices);
}
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
- searchHeapBlocks (addrs, generations[g].blocks);
- searchHeapBlocks (addrs, generations[g].large_objects);
+ searchHeapBlocks (addrs, generations[g].blocks, s_indices);
+ searchHeapBlocks (addrs, generations[g].large_objects, s_indices);
for (n = 0; n < n_capabilities; n++) {
ws = &gc_threads[n]->gens[g];
- searchHeapBlocks(addrs, ws->todo_bd);
- searchHeapBlocks(addrs, ws->part_list);
- searchHeapBlocks(addrs, ws->scavd_list);
+ searchHeapBlocks(addrs, ws->todo_bd, s_indices);
+ searchHeapBlocks(addrs, ws->part_list, s_indices);
+ searchHeapBlocks(addrs, ws->scavd_list, s_indices);
}
}
#if defined(PROFILING)
/* Traverse the cost centre tree, calling checkAddress on each CCS/CC */
- searchCostCentres(addrs, CCS_MAIN);
+ searchCostCentres(addrs, CCS_MAIN, s_indices);
/* Also check each cost centre in the CC_LIST */
CostCentre *cc;
for (cc = CC_LIST; cc != NULL; cc = cc->link) {
- checkAddress(addrs, cc);
+ checkAddress(addrs, cc, s_indices);
}
#endif /* PROFILING */
+ freeOCSectionIndices(s_indices);
// Look through the unloadable objects, and any object that is still
// marked as unreferenced can be physically unloaded, because we
// have no references to it.
=====================================
rts/linker/Elf.c
=====================================
@@ -732,12 +732,8 @@ ocGetNames_ELF ( ObjectCode* oc )
unsigned nstubs = numberOfStubsForSection(oc, i);
unsigned stub_space = STUB_SIZE * nstubs;
- void * mem = mmap(NULL, size+stub_space,
- PROT_READ | PROT_WRITE | PROT_EXEC,
- MAP_ANON | MAP_PRIVATE,
- -1, 0);
-
- if( mem == MAP_FAILED ) {
+ void * mem = mmapForLinker(size+stub_space, MAP_ANON, -1, 0);
+ if( mem == NULL ) {
barf("failed to mmap allocated memory to load section %d. "
"errno = %d", i, errno);
}
=====================================
rts/linker/elf_got.c
=====================================
@@ -52,18 +52,18 @@ makeGot(ObjectCode * oc) {
errorBelch("MAP_FAILED. errno=%d", errno);
return EXIT_FAILURE;
}
+
oc->info->got_start = (void*)mem;
/* update got_addr */
size_t slot = 0;
for(ElfSymbolTable *symTab = oc->info->symbolTables;
- symTab != NULL; symTab = symTab->next)
+ symTab != NULL; symTab = symTab->next) {
+
for(size_t i=0; i < symTab->n_symbols; i++)
if(needGotSlot(symTab->symbols[i].elf_sym))
symTab->symbols[i].got_addr
= (uint8_t *)oc->info->got_start
+ (slot++ * sizeof(void*));
- if(mprotect(mem, oc->info->got_size, PROT_READ) != 0) {
- sysErrorBelch("unable to protect memory");
}
}
return EXIT_SUCCESS;
@@ -74,9 +74,12 @@ fillGot(ObjectCode * oc) {
/* fill the GOT table */
for(ElfSymbolTable *symTab = oc->info->symbolTables;
symTab != NULL; symTab = symTab->next) {
+
for(size_t i=0; i < symTab->n_symbols; i++) {
ElfSymbol * symbol = &symTab->symbols[i];
+
if(needGotSlot(symbol->elf_sym)) {
+
/* no type are undefined symbols */
if( STT_NOTYPE == ELF_ST_TYPE(symbol->elf_sym->st_info)
|| STB_WEAK == ELF_ST_BIND(symbol->elf_sym->st_info)) {
@@ -93,22 +96,31 @@ fillGot(ObjectCode * oc) {
} /* else it was defined somewhere in the same object, and
* we should have the address already.
*/
+
if(0x0 == symbol->addr) {
errorBelch(
"Something went wrong! Symbol %s has null address.\n",
symbol->name);
return EXIT_FAILURE;
}
+
if(0x0 == symbol->got_addr) {
errorBelch("Not good either!");
return EXIT_FAILURE;
}
+
*(void**)symbol->got_addr = symbol->addr;
}
}
}
+
+ // We are done initializing the GOT; freeze it.
+ if(mprotect(oc->info->got_start, oc->info->got_size, PROT_READ) != 0) {
+ sysErrorBelch("unable to protect memory");
+ }
return EXIT_SUCCESS;
}
+
bool
verifyGot(ObjectCode * oc) {
for(ElfSymbolTable *symTab = oc->info->symbolTables;
=====================================
testsuite/tests/rts/unload_multiple_objs/A.hs
=====================================
@@ -0,0 +1,16 @@
+module A where
+
+import Foreign.StablePtr
+
+id1 :: Int
+id1 = 1
+
+createHeapObjectA :: IO (StablePtr [Int])
+createHeapObjectA = do
+ newStablePtr [2+id1]
+
+freeHeapObjectA :: StablePtr [Int] -> IO ()
+freeHeapObjectA obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectA :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectA :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/unload_multiple_objs/B.hs
=====================================
@@ -0,0 +1,16 @@
+module B where
+
+import Foreign.StablePtr
+
+id2 :: Int
+id2 = 2
+
+createHeapObjectB :: IO (StablePtr [Int])
+createHeapObjectB = do
+ newStablePtr [2+id2]
+
+freeHeapObjectB :: StablePtr [Int] -> IO ()
+freeHeapObjectB obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectB :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectB :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/unload_multiple_objs/C.hs
=====================================
@@ -0,0 +1,16 @@
+module C where
+
+import Foreign.StablePtr
+
+id3 :: Int
+id3 = 3
+
+createHeapObjectC :: IO (StablePtr [Int])
+createHeapObjectC = do
+ newStablePtr [2+id3]
+
+freeHeapObjectC :: StablePtr [Int] -> IO ()
+freeHeapObjectC obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectC :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectC :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/unload_multiple_objs/D.hs
=====================================
@@ -0,0 +1,16 @@
+module D where
+
+import Foreign.StablePtr
+
+id4 :: Int
+id4 = 4
+
+createHeapObjectD :: IO (StablePtr [Int])
+createHeapObjectD = do
+ newStablePtr [2+id4]
+
+freeHeapObjectD :: StablePtr [Int] -> IO ()
+freeHeapObjectD obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectD :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectD :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/unload_multiple_objs/Makefile
=====================================
@@ -0,0 +1,17 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: linker_unload_multiple_objs
+linker_unload_multiple_objs:
+ $(RM) A.o B.o C.o D.o
+ $(RM) A.hi B.hi C.hi D.hi
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c A.hs -v0
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c B.hs -v0
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c C.hs -v0
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c D.hs -v0
+ # -rtsopts causes a warning
+ "$(TEST_HC)" LinkerUnload.hs -package ghc $(filter-out -rtsopts, $(TEST_HC_OPTS)) linker_unload_multiple_objs.c -o linker_unload_multiple_objs -no-hs-main -optc-Werror
+ ./linker_unload_multiple_objs "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+
=====================================
testsuite/tests/rts/unload_multiple_objs/all.T
=====================================
@@ -0,0 +1,4 @@
+test('linker_unload_multiple_objs',
+ [extra_files(['../LinkerUnload.hs', 'A.hs', 'B.hs', 'C.hs', 'D.hs',]),
+ when(arch('powerpc64') or arch('powerpc64le'), expect_broken(11259))],
+ run_command, ['$MAKE -s --no-print-directory linker_unload_multiple_objs'])
=====================================
testsuite/tests/rts/unload_multiple_objs/linker_unload_multiple_objs.c
=====================================
@@ -0,0 +1,147 @@
+#include "ghcconfig.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include "Rts.h"
+#include <string.h>
+#include "HsFFI.h"
+
+extern void loadPackages(void);
+
+#define NUM_OBJS 4
+
+static char *objs[NUM_OBJS] = {"A.o", "B.o", "C.o", "D.o"};
+
+pathchar* toPathchar(char* path)
+{
+#if defined(mingw32_HOST_OS)
+ size_t required = strlen(path);
+ pathchar *ret = (pathchar*)malloc(sizeof(pathchar) * (required + 1));
+ if (mbstowcs(ret, path, required) == (size_t)-1)
+ {
+ errorBelch("toPathchar failed converting char* to wchar_t*: %s", path);
+ exit(1);
+ }
+ ret[required] = '\0';
+ return ret;
+#else
+ return path;
+#endif
+}
+
+void load_and_resolve_all_objects() {
+ int i, r;
+ for (i = 0; i < NUM_OBJS; i++) {
+ r = loadObj(toPathchar(objs[i]));
+ if (!r) {
+ errorBelch("loadObj(%s) failed", objs[i]);
+ exit(1);
+ }
+ }
+
+ r = resolveObjs();
+ if (!r) {
+ errorBelch("resolveObjs failed");
+ exit(1);
+ }
+
+ for (i = 0; i < NUM_OBJS; i++) {
+ char sym_name[138] = {0};
+#if LEADING_UNDERSCORE
+ sprintf(sym_name, "_createHeapObject%c", 'A'+i);
+#else
+ sprintf(sym_name, "createHeapObject%c", 'A'+i);
+#endif
+ void *sym_addr = lookupSymbol(sym_name);
+ if (!sym_addr) {
+ errorBelch("lookupSymbol(%s) failed", sym_name);
+ exit(1);
+ }
+ }
+}
+
+void check_object_freed(char *obj_path) {
+ OStatus st;
+ st = getObjectLoadStatus(toPathchar(obj_path));
+ if (st != OBJECT_NOT_LOADED) {
+ errorBelch("object %s status != OBJECT_NOT_LOADED", obj_path);
+ exit(1);
+ }
+}
+
+void check_object_unloaded_but_not_freed(char *obj_path) {
+ OStatus st;
+ st = getObjectLoadStatus(toPathchar(obj_path));
+ if (st != OBJECT_UNLOADED) {
+ errorBelch("object %s status != OBJECT_UNLOADED, is %d instead", obj_path, st);
+ exit(1);
+ }
+}
+
+void test_no_dangling_references_to_unloaded_objects()
+{
+ load_and_resolve_all_objects();
+
+ unloadObj(toPathchar("A.o"));
+ unloadObj(toPathchar("B.o"));
+ unloadObj(toPathchar("C.o"));
+ unloadObj(toPathchar("D.o"));
+ performMajorGC();
+
+ check_object_freed("A.o");
+ check_object_freed("B.o");
+ check_object_freed("C.o");
+ check_object_freed("D.o");
+
+}
+
+typedef HsStablePtr stableptrfun_t(void);
+typedef void freeptrfun_t(HsStablePtr);
+
+void test_still_has_references_to_unloaded_objects()
+{
+ load_and_resolve_all_objects();
+#if LEADING_UNDERSCORE
+ stableptrfun_t *createHeapObject = lookupSymbol("_createHeapObjectD");
+ freeptrfun_t *freeHeapObject = lookupSymbol("_freeHeapObjectD");
+#else
+ stableptrfun_t *createHeapObject = lookupSymbol("createHeapObjectD");
+ freeptrfun_t *freeHeapObject = lookupSymbol("freeHeapObjectD");
+#endif
+ HsStablePtr ptr = createHeapObject();
+
+ unloadObj(toPathchar("A.o"));
+ unloadObj(toPathchar("B.o"));
+ unloadObj(toPathchar("C.o"));
+ unloadObj(toPathchar("D.o"));
+ performMajorGC();
+
+ check_object_freed("A.o");
+ check_object_freed("B.o");
+ check_object_freed("C.o");
+ check_object_unloaded_but_not_freed("D.o");
+
+
+ freeHeapObject(ptr);
+ performMajorGC();
+
+ check_object_freed("A.o");
+ check_object_freed("B.o");
+ check_object_freed("C.o");
+ check_object_freed("D.o");
+}
+
+int main (int argc, char *argv[])
+{
+ RtsConfig conf = defaultRtsConfig;
+ conf.rts_opts_enabled = RtsOptsAll;
+ hs_init_ghc(&argc, &argv, conf);
+
+ initLinker_(0);
+ loadPackages();
+
+ test_still_has_references_to_unloaded_objects();
+ test_no_dangling_references_to_unloaded_objects();
+
+ hs_exit();
+ exit(0);
+}
=====================================
testsuite/tests/rts/unload_multiple_objs/linker_unload_multiple_objs.stdout
=====================================
@@ -0,0 +1,2 @@
+[1 of 1] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o )
+Linking linker_unload_multiple_objs ...
=====================================
utils/llvm-targets/gen-data-layout.sh
=====================================
@@ -24,6 +24,7 @@ TARGETS=(
# Linux ARM
"arm-unknown-linux-gnueabihf" "armv6-unknown-linux-gnueabihf" "armv6l-unknown-linux-gnueabihf"
"armv7-unknown-linux-gnueabihf" "armv7a-unknown-linux-gnueabi" "armv7l-unknown-linux-gnueabihf"
+ "armv7l-unknown-linux-gnueabi"
"aarch64-unknown-linux-gnu" "aarch64-unknown-linux"
# Linux x86
"i386-unknown-linux-gnu" "i386-unknown-linux" "x86_64-unknown-linux-gnu" "x86_64-unknown-linux"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/5e6f261aee196eb5984d192dcb01710b070452b3...e9d603ef2b663aa15dc61cba07d6c3b308bc6d42
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/5e6f261aee196eb5984d192dcb01710b070452b3...e9d603ef2b663aa15dc61cba07d6c3b308bc6d42
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/20190613/f82ef07e/attachment-0001.html>
More information about the ghc-commits
mailing list