Commit eeca442c authored by Ben Gamari's avatar Ben Gamari 🐢
Browse files

Merge branches 'wip/backport-MR1137', 'wip/backport-MR1139',...

Merge branches 'wip/backport-MR1137', 'wip/backport-MR1139', 'wip/backport-MR1160', 'wip/backport-MR706' and 'wip/backport-MR769' into wip/ghc-8.8-merges
......@@ -30,6 +30,7 @@ BuildFlavour=$BUILD_FLAVOUR
ifneq "\$(BuildFlavour)" ""
include mk/flavours/\$(BuildFlavour).mk
endif
GhcLibHcOpts+=-haddock
EOF
case "$(uname)" in
......
......@@ -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'
......
......@@ -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", ""))
......
......@@ -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.
......
......@@ -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);
}
......
......@@ -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;
......
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 ()
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 ()
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 ()
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 ()
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'`"
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'])
#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;