summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2020-11-21 11:27:06 -0500
committerGHC GitLab CI <ghc-ci@gitlab-haskell.org>2020-11-24 01:17:25 +0000
commita226fc88e87d43898c64dbc75d867319029c26b0 (patch)
tree377d6ecfe408cd968deee140a2deab9f112c0113
parenta94ffd1b5080227b9016b0b136d8bdd4540e357f (diff)
downloadhaskell-a226fc88e87d43898c64dbc75d867319029c26b0.tar.gz
Revert "Apply upstream patch 3842: Linker: Object unloading"
This reverts commit e508c92828c7e009b6f7df16cd7be2147c4a9026.
-rw-r--r--rts/CheckUnload.c860
-rw-r--r--rts/CheckUnload.h30
-rw-r--r--rts/Hash.c28
-rw-r--r--rts/Hash.h34
-rw-r--r--rts/Linker.c376
-rw-r--r--rts/LinkerInternals.h87
-rw-r--r--rts/RtsStartup.c3
-rw-r--r--rts/linker/Elf.c4
-rw-r--r--rts/linker/LoadArchive.c11
-rw-r--r--rts/linker/MachO.c16
-rw-r--r--rts/linker/PEi386.c2
-rw-r--r--rts/linker/elf_got.c2
-rw-r--r--rts/sm/Evac.c6
-rw-r--r--rts/sm/GC.c13
-rw-r--r--rts/sm/HeapUtils.h38
-rw-r--r--testsuite/tests/ghci/T16525a/T16525a.script6
-rw-r--r--testsuite/tests/ghci/T16525a/T16525a.stdout1
-rw-r--r--testsuite/tests/ghci/T16525a/all.T4
-rw-r--r--testsuite/tests/ghci/T16525b/A.hs6
-rw-r--r--testsuite/tests/ghci/T16525b/B.hs5
-rw-r--r--testsuite/tests/ghci/T16525b/T16525b.script22
-rw-r--r--testsuite/tests/ghci/T16525b/T16525b.stdout4
-rw-r--r--testsuite/tests/ghci/T16525b/all.T2
-rw-r--r--testsuite/tests/rts/linker_error.c3
-rw-r--r--testsuite/tests/rts/linker_unload_native.c23
-rw-r--r--testsuite/tests/rts/linker_unload_native.stdout1
26 files changed, 824 insertions, 763 deletions
diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c
index 30cdec9b8b..e524828e40 100644
--- a/rts/CheckUnload.c
+++ b/rts/CheckUnload.c
@@ -17,99 +17,43 @@
#include "CheckUnload.h"
#include "sm/Storage.h"
#include "sm/GCThread.h"
-#include "sm/HeapUtils.h"
//
-// Note [Object unloading]
-// ~~~~~~~~~~~~~~~~~~~~~~~
+// Code that we unload may be referenced from:
+// - info pointers in heap objects and stack frames
+// - pointers to static objects from the heap
+// - StablePtrs to static objects
+// - pointers to cost centres from the cost centre tree
//
-// Overview of object unloading:
+// We can find live static objects after a major GC, so we don't have
+// to look at every closure pointer in the heap. However, we do have
+// to look at every info pointer. So this is like a heap census
+// traversal: we look at the header of every object, but not its
+// contents.
//
-// - In a major GC, for every static object we mark the object's object code and
-// its dependencies as 'live'. This is done by `markObjectCode`, called by
-// `evacuate`.
-//
-// - Marking object code is done using a global "section index table"
-// (global_s_indices below). When we load an object code we add its section
-// indices to the table. `markObjectCode` does binary search on this table to
-// find object code for the marked object, and mark it and its dependencies.
-//
-// Dependency of an object code is simply other object code that the object
-// code refers to in its code. We know these dependencies by the relocations
-// present in the referent. This is recorded by lookupSymbolDependent.
-//
-// - global_s_indices is updated as we load and unload objects. When we load an
-// object code we add its section indices to the table, we remove those
-// indices when we unload.
-//
-// The table is sorted and old indices are removed in `checkUnload`, instead
-// on every load/unload, to avoid quadratic behavior when we load a list of
-// objects.
-//
-// - After a major GC `checkUnload` unloads objects that are (1) explicitly
-// asked for unloading (via `unloadObj`) and (2) are not marked during GC.
-//
-// Note that, crucially, we don't unload an object code even if it's not
-// reachable from the heap, unless it's explicitly asked for unloading (via
-// `unloadObj`). This is a feature and not a but! Two use cases:
-//
-// - The user might request a symbol from a loaded object at any point with
-// lookupSymbol (e.g. GHCi might do this).
-//
-// - Sometimes we load objects that are not Haskell objects.
-//
-// To avoid unloading objects that are unreachable but are not asked for
-// unloading we maintain a "root set" of object code, `loaded_objects` below.
-// `loadObj` adds the loaded objects (and its dependencies) to the list.
-// `unloadObj` removes. After a major GC, `checkUnload` first marks the root set
-// (`loaded_objects`) to avoid unloading objects that are not asked for
-// unloading.
-//
-// Two other lists `objects` and `old_objects` are similar to large object lists
-// in GC. Before a major GC we move `objects` to `old_objects`, and move marked
-// objects back to `objects` during evacuation and when marking roots in
-// `checkUnload`. Any objects in `old_objects` after that is unloaded.
-//
-// TODO: We currently don't unload objects when non-moving GC is enabled. The
-// implementation would be similar to `nonmovingGcCafs`:
-//
-// - Maintain a "snapshot":
-//
-// - Copy `loaded_objects` as the root set of the snapshot
-//
-// - Stash `objects` to `old_objects` as the snapshot. We don't need a new
-// list for this as `old_objects` won't be used by any other code when
-// non-moving GC is enabled.
-//
-// - Copy `global_s_indices` table to be able to mark objects while mutators
-// call `loadObj_` and `unloadObj_` concurrently.
-//
-// - Don't mark object code in `evacuate`, marking will be done in the
-// non-moving collector.
-//
-// - After preparation, bump the object code mark bit (`object_code_mark_bit`
-// below) and mark static objects using a version of `markObjectCode` that
-// basically does the same thing but:
-//
-// - Needs to update `objects` list in a thread-safe way, as mutators will be
-// concurrently calling `loadObj_` and add new stuff to `objects`.
-// (alternatively we could have a new list for non-moving GC's objects list,
-// and then merge it to the global list in the pause before moving to
-// concurrent sweep phase)
-//
-// - Needs to use the copied `global_s_indices`
-//
-// - After marking anything left in `old_objects` are unreachable objects within
-// the snapshot, unload those. The unload loop will be the same as in
-// `checkUnload`. This step needs to happen in the final sync (before sweep
-// begins) to avoid races when updating `global_s_indices`.
-//
-// - NOTE: We don't need write barriers in loadObj/unloadObj as we don't
-// introduce a dependency from an already-loaded object to a newly loaded
-// object and we don't delete existing dependencies.
+// On the assumption that there aren't many different info pointers in
+// a typical heap, we insert addresses into a hash table. The
+// first time we see an address, we check it against the pending
+// unloadable objects and if it lies within any of them, we mark that
+// object as referenced so that it won't get unloaded in this round.
//
-uint8_t object_code_mark_bit = 0;
+// 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;
@@ -118,85 +62,20 @@ typedef struct {
} OCSectionIndex;
typedef struct {
- int capacity; // Doubled on resize
int n_sections;
- bool sorted; // Invalidated on insertion. Sorted in checkUnload.
- bool unloaded; // Whether we removed anything from the table in
- // removeOCSectionIndices. If this is set we "compact" the
- // table (remove unused entries) in `sortOCSectionIndices.
OCSectionIndex *indices;
} OCSectionIndices;
-// List of currently live objects. Moved to `old_objects` before unload check.
-// Marked objects moved back to this list in `markObjectLive`. Remaining objects
-// are freed at the end of `checkUnload`.
-//
-// Double-linked list to be able to remove marked objects. List formed with
-// `next` and `prev` fields of `ObjectCode`.
-//
-// Not static: used in Linker.c.
-ObjectCode *objects = NULL;
-
-// `objects` list is moved here before unload check. Marked objects are moved
-// back to `objects`. Remaining objects are freed.
-static ObjectCode *old_objects = NULL;
-
-// Number of objects that we want to unload. When this value is 0 we skip static
-// object marking during GC and `checkUnload`.
-//
-// Not static: we use this value to skip static object marking in evacuate when
-// this is 0.
-//
-// Incremented in `unloadObj_`, decremented as we unload objects in
-// `checkUnload`.
-int n_unloaded_objects = 0;
-
-// List of objects that we don't want to unload (i.e. we haven't called
-// unloadObj on these yet). Used as root set for unload check in checkUnload.
-// Objects are added with loadObj_ and removed with unloadObj_.
-//
-// List formed with `next_loaded_object` field of `ObjectCode`.
-//
-// Not static: used in Linker.c.
-ObjectCode *loaded_objects;
-
-// Section index table for currently loaded objects. New indices are added by
-// `loadObj_`, indices of unloaded objects are removed in `checkUnload`. Used to
-// map static closures to their ObjectCode.
-static OCSectionIndices *global_s_indices = NULL;
-
-static OCSectionIndices *createOCSectionIndices(void)
+static OCSectionIndices *createOCSectionIndices(int n_sections)
{
- // TODO (osa): Maybe initialize as empty (without allocation) and allocate
- // on first insertion?
- OCSectionIndices *s_indices = stgMallocBytes(sizeof(OCSectionIndices), "OCSectionIndices");
- int capacity = 1024;
- s_indices->capacity = capacity;
- s_indices->n_sections = 0;
- s_indices->sorted = true;
- s_indices->unloaded = false;
- s_indices->indices = stgMallocBytes(capacity * sizeof(OCSectionIndex),
+ 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 void freeOCSectionIndices(OCSectionIndices *s_indices)
-{
- free(s_indices->indices);
- free(s_indices);
-}
-
-void initUnloadCheck()
-{
- global_s_indices = createOCSectionIndices();
-}
-
-void exitUnloadCheck()
-{
- freeOCSectionIndices(global_s_indices);
- global_s_indices = NULL;
-}
-
static int cmpSectionIndex(const void* indexa, const void *indexb)
{
W_ s1 = ((OCSectionIndex*)indexa)->start;
@@ -209,148 +88,44 @@ static int cmpSectionIndex(const void* indexa, const void *indexb)
return 0;
}
-static void reserveOCSectionIndices(OCSectionIndices *s_indices, int len)
+static OCSectionIndices* buildOCSectionIndices(ObjectCode *ocs)
{
- int current_capacity = s_indices->capacity;
- int current_len = s_indices->n_sections;
- if (current_capacity - current_len >= len) {
- return;
- }
-
- // Round up to nearest power of 2
- int new_capacity = 1 << (int)ceil(log2(current_len + len));
-
- OCSectionIndex *old_indices = s_indices->indices;
- OCSectionIndex *new_indices = stgMallocBytes(new_capacity * sizeof(OCSectionIndex),
- "reserveOCSectionIndices");
-
- for (int i = 0; i < current_len; ++i) {
- new_indices[i] = old_indices[i];
+ int cnt_sections = 0;
+ ObjectCode *oc;
+ for (oc = ocs; oc; oc = oc->next) {
+ cnt_sections += oc->n_sections;
}
-
- s_indices->capacity = new_capacity;
- s_indices->indices = new_indices;
-
- free(old_indices);
-}
-
-// Insert object section indices of a single ObjectCode. Invalidates 'sorted'
-// state.
-void insertOCSectionIndices(ObjectCode *oc)
-{
- // after we finish the section table will no longer be sorted.
- global_s_indices->sorted = false;
-
- if (oc->type == DYNAMIC_OBJECT) {
- // First count the ranges
- int n_ranges = 0;
- for (NativeCodeRange *ncr = oc->nc_ranges; ncr != NULL; ncr = ncr->next) {
- n_ranges++;
- }
-
- // Next reserve the appropriate number of table entries...
- reserveOCSectionIndices(global_s_indices, n_ranges);
-
- // Now insert the new ranges...
- int s_i = global_s_indices->n_sections;
- for (NativeCodeRange *ncr = oc->nc_ranges; ncr != NULL; ncr = ncr->next) {
- OCSectionIndex *ent = &global_s_indices->indices[s_i];
- ent->start = (W_)ncr->start;
- ent->end = (W_)ncr->end;
- ent->oc = oc;
- s_i++;
- }
-
- global_s_indices->n_sections = s_i;
- } else {
- reserveOCSectionIndices(global_s_indices, oc->n_sections);
- int s_i = global_s_indices->n_sections;
- for (int i = 0; i < oc->n_sections; i++) {
+ 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) {
- OCSectionIndex *ent = &global_s_indices->indices[s_i];
- ent->start = (W_)oc->sections[i].start;
- ent->end = (W_)oc->sections[i].start + oc->sections[i].size;
- ent->oc = oc;
+ 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++;
}
}
-
- global_s_indices->n_sections = s_i;
}
-
- // Add object to 'objects' list
- if (objects != NULL) {
- objects->prev = oc;
- }
- oc->next = objects;
- objects = oc;
-}
-
-static int findSectionIdx(OCSectionIndices *s_indices, const void *addr);
-
-static void removeOCSectionIndices(OCSectionIndices *s_indices, ObjectCode *oc)
-{
- // To avoid quadratic behavior in checkUnload we set `oc` fields of indices
- // of unloaded objects NULL here. Removing unused entries is done in
- // `sortOCSectionIndices`.
-
- s_indices->unloaded = true;
-
- for (int i = 0; i < oc->n_sections; i++) {
- if (oc->sections[i].kind != SECTIONKIND_OTHER) {
- int section_idx = findSectionIdx(s_indices, oc->sections[i].start);
- if (section_idx != -1) {
- s_indices->indices[section_idx].oc = NULL;
- }
- }
- }
-}
-
-static void sortOCSectionIndices(OCSectionIndices *s_indices) {
- if (s_indices->sorted) {
- return;
- }
-
+ s_indices->n_sections = s_i;
qsort(s_indices->indices,
s_indices->n_sections,
sizeof(OCSectionIndex),
cmpSectionIndex);
-
- s_indices->sorted = true;
+ return s_indices;
}
-static void removeRemovedOCSections(OCSectionIndices *s_indices) {
- if (!s_indices->unloaded) {
- return;
- }
-
- int next_free_idx = 0;
- for (int i = 0; i < s_indices->n_sections; ++i) {
- if (s_indices->indices[i].oc == NULL) {
- // free entry, skip
- } else if (i == next_free_idx) {
- ++next_free_idx;
- } else {
- s_indices->indices[next_free_idx] = s_indices->indices[i];
- ++next_free_idx;
- }
- }
-
- s_indices->n_sections = next_free_idx;
- s_indices->unloaded = true;
+static void freeOCSectionIndices(OCSectionIndices *section_indices)
+{
+ free(section_indices->indices);
+ free(section_indices);
}
-// Returns -1 if not found
-static int findSectionIdx(OCSectionIndices *s_indices, const void *addr) {
- ASSERT(s_indices->sorted);
-
+static ObjectCode *findOC(OCSectionIndices *s_indices, const void *addr) {
W_ w_addr = (W_)addr;
- if (s_indices->n_sections <= 0) {
- return -1;
- }
- if (w_addr < s_indices->indices[0].start) {
- return -1;
- }
+ 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) {
@@ -364,121 +139,466 @@ static int findSectionIdx(OCSectionIndices *s_indices, const void *addr) {
}
ASSERT(w_addr >= s_indices->indices[left].start);
if (w_addr < s_indices->indices[left].end) {
- return left;
+ return s_indices->indices[left].oc;
}
- return -1;
+ return NULL;
}
-static ObjectCode *findOC(OCSectionIndices *s_indices, const void *addr) {
- int oc_idx = findSectionIdx(s_indices, addr);
- if (oc_idx == -1) {
- return NULL;
- }
-
- return s_indices->indices[oc_idx].oc;
-}
+static void checkAddress (HashTable *addrs, const void *addr,
+ OCSectionIndices *s_indices)
+{
+ ObjectCode *oc;
+ NativeCode *nc;
+ NativeCodeRange *ncr;
-static bool markObjectLive(void *data STG_UNUSED, StgWord key, const void *value STG_UNUSED) {
- ObjectCode *oc = (ObjectCode*)key;
- if (oc->mark == object_code_mark_bit) {
- return true; // for hash table iteration
- }
+ if (!lookupHashTable(addrs, (W_)addr)) {
+ insertHashTable(addrs, (W_)addr, addr);
- oc->mark = object_code_mark_bit;
- // Remove from 'old_objects' list
- if (oc->prev != NULL) {
- // TODO(osa): Maybe 'prev' should be a pointer to the referencing
- // *field* ? (instead of referencing *object*)
- oc->prev->next = oc->next;
- } else {
- old_objects = oc->next;
- }
- if (oc->next != NULL) {
- oc->next->prev = oc->prev;
- }
+ oc = findOC(s_indices, addr);
+ if (oc != NULL) {
+ oc->referenced = 1;
+ return;
+ }
- // Add it to 'objects' list
- oc->prev = NULL;
- oc->next = objects;
- if (objects != NULL) {
- objects->prev = oc;
+ for (nc = unloaded_native_objects; nc; nc = nc->next) {
+ for (ncr = nc->nc_ranges; ncr; ncr = ncr->next) {
+ if (addr >= ncr->start && addr < ncr->end) {
+ nc->referenced = 1;
+ return;
+ }
+ }
+ }
}
- objects = oc;
-
- // Mark its dependencies
- iterHashTable(oc->dependencies, NULL, markObjectLive);
-
- return true; // for hash table iteration
}
-void markObjectCode(const void *addr)
+static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end,
+ OCSectionIndices *s_indices)
{
- if (global_s_indices == NULL) {
- return;
- }
+ StgPtr p;
+ const StgRetInfoTable *info;
+
+ p = sp;
+ while (p < stack_end) {
+ info = get_ret_itbl((StgClosure *)p);
- // This should be checked at the call site
- ASSERT(!HEAP_ALLOCED(addr));
+ switch (info->i.type) {
+ case RET_SMALL:
+ case RET_BIG:
+ checkAddress(addrs, (const void*)info, s_indices);
+ break;
+
+ default:
+ break;
+ }
- ObjectCode *oc = findOC(global_s_indices, addr);
- if (oc != NULL) {
- // Mark the object code and its dependencies
- markObjectLive(NULL, (W_)oc, NULL);
+ p += stack_frame_sizeW((StgClosure*)p);
}
}
-void prepareUnloadCheck(void)
+
+static void searchHeapBlocks (HashTable *addrs, bdescr *bd,
+ OCSectionIndices *s_indices)
{
- if (global_s_indices == NULL) {
- return;
- }
+ StgPtr p;
+ const StgInfoTable *info;
+ uint32_t size;
+ bool prim;
- removeRemovedOCSections(global_s_indices);
- sortOCSectionIndices(global_s_indices);
+ for (; bd != NULL; bd = bd->link) {
- ASSERT(old_objects == NULL);
+ if (bd->flags & BF_PINNED) {
+ // Assume that objects in PINNED blocks cannot refer to
+ continue;
+ }
- object_code_mark_bit = ~object_code_mark_bit;
- old_objects = objects;
- objects = NULL;
-}
+ p = bd->start;
+ while (p < bd->free) {
+ info = get_itbl((StgClosure *)p);
+#ifdef PROFILING
+ // mark CCS as referenced by the heap so it is not pruned while
+ // generating the profile snapshot
+ setCCSBitFlag(((StgClosure *)p)->header.prof.ccs, CCS_REFERENCED);
+#endif
+ prim = false;
+
+ switch (info->type) {
+
+ case THUNK:
+ size = thunk_sizeW_fromITBL(info);
+ break;
+
+ case THUNK_1_1:
+ case THUNK_0_2:
+ case THUNK_2_0:
+ size = sizeofW(StgThunkHeader) + 2;
+ break;
+
+ case THUNK_1_0:
+ case THUNK_0_1:
+ case THUNK_SELECTOR:
+ size = sizeofW(StgThunkHeader) + 1;
+ break;
+
+ case FUN:
+ case FUN_1_0:
+ case FUN_0_1:
+ case FUN_1_1:
+ case FUN_0_2:
+ case FUN_2_0:
+ case CONSTR:
+ case CONSTR_NOCAF:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_2_0:
+ size = sizeW_fromITBL(info);
+ break;
+
+ case BLACKHOLE:
+ case BLOCKING_QUEUE:
+ prim = true;
+ size = sizeW_fromITBL(info);
+ break;
+
+ case IND:
+ // Special case/Delicate Hack: INDs don't normally
+ // appear, since we're doing this heap census right
+ // after GC. However, GarbageCollect() also does
+ // resurrectThreads(), which can update some
+ // blackholes when it calls raiseAsync() on the
+ // resurrected threads. So we know that any IND will
+ // be the size of a BLACKHOLE.
+ prim = true;
+ size = BLACKHOLE_sizeW();
+ break;
+
+ case BCO:
+ prim = true;
+ size = bco_sizeW((StgBCO *)p);
+ break;
+
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
+ case TVAR:
+ case WEAK:
+ case PRIM:
+ case MUT_PRIM:
+ case MUT_VAR_CLEAN:
+ case MUT_VAR_DIRTY:
+ prim = true;
+ size = sizeW_fromITBL(info);
+ break;
+
+ case AP:
+ prim = true;
+ size = ap_sizeW((StgAP *)p);
+ break;
+
+ case PAP:
+ prim = true;
+ size = pap_sizeW((StgPAP *)p);
+ break;
+
+ case AP_STACK:
+ {
+ StgAP_STACK *ap = (StgAP_STACK *)p;
+ prim = true;
+ size = ap_stack_sizeW(ap);
+ searchStackChunk(addrs, (StgPtr)ap->payload,
+ (StgPtr)ap->payload + ap->size, s_indices);
+ break;
+ }
-void checkUnload(void)
-{
- if (global_s_indices == NULL) {
- return;
+ case ARR_WORDS:
+ prim = true;
+ size = arr_words_sizeW((StgArrBytes*)p);
+ break;
+
+ case MUT_ARR_PTRS_CLEAN:
+ case MUT_ARR_PTRS_DIRTY:
+ case MUT_ARR_PTRS_FROZEN_CLEAN:
+ case MUT_ARR_PTRS_FROZEN_DIRTY:
+ prim = true;
+ size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
+ break;
+
+ case SMALL_MUT_ARR_PTRS_CLEAN:
+ case SMALL_MUT_ARR_PTRS_DIRTY:
+ case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
+ case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
+ prim = true;
+ size = small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)p);
+ break;
+
+ case TSO:
+ prim = true;
+ size = sizeofW(StgTSO);
+ break;
+
+ case STACK: {
+ StgStack *stack = (StgStack*)p;
+ prim = true;
+ searchStackChunk(addrs, stack->sp,
+ stack->stack + stack->stack_size, s_indices);
+ size = stack_sizeW(stack);
+ break;
+ }
+
+ case TREC_CHUNK:
+ prim = true;
+ size = sizeofW(StgTRecChunk);
+ break;
+
+ default:
+ barf("heapCensus, unknown object: %d", info->type);
+ }
+
+ if (!prim) {
+ checkAddress(addrs,info, s_indices);
+ }
+
+ p += size;
+ }
}
+}
- // At this point we've marked all dynamically loaded static objects
- // (including their dependencies) during GC, but not the root set of object
- // code (loaded_objects). Mark the roots first, then unload any unmarked
- // objects.
- OCSectionIndices *s_indices = global_s_indices;
- ASSERT(s_indices->sorted);
+#if defined(PROFILING)
+//
+// 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,
+ OCSectionIndices* s_indices)
+{
+ IndexTable *i;
- // Mark roots
- for (ObjectCode *oc = loaded_objects; oc != NULL; oc = oc->next_loaded_object) {
- markObjectLive(NULL, (W_)oc, NULL);
+ 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, s_indices);
+ }
}
+}
- // Free unmarked objects
- ObjectCode *next = NULL;
- for (ObjectCode *oc = old_objects; oc != NULL; oc = next) {
- next = oc->next;
- ASSERT(oc->status == OBJECT_UNLOADED);
+//
+// Prune the CCS tree.
+// Assumes CCS_REFERENCED bit has been set on all CCSs referenced by the heap.
+// Resulting CCS tree has CCS_REFERENCED bit cleared on all CCSs.
+//
+static CostCentreStack *
+gcCostCentreStacks (CostCentreStack *ccs)
+{
+ CostCentreStack *ccs1;
+ IndexTable *i, **prev;
- removeOCSectionIndices(s_indices, oc);
+ prev = &ccs->indexTable;
+ for (i = ccs->indexTable; i != NULL; i = i->next) {
+ if (i->back_edge) { continue; }
- // Symbols should be removed by unloadObj_.
- // NB (osa): If this assertion doesn't hold then freeObjectCode below
- // will corrupt symhash as keys of that table live in ObjectCodes. If
- // you see a segfault in a hash table operation in linker (in non-debug
- // RTS) then it's probably becuse this assertion did not hold.
- ASSERT(oc->symbols == NULL);
+ ccs1 = gcCostCentreStacks(i->ccs);
+ if (ccs1 == NULL) {
+ *prev = i->next;
+ } else {
+ prev = &(i->next);
+ }
+ }
- freeObjectCode(oc);
- n_unloaded_objects -= 1;
+ if ( testCCSBitFlag(ccs, CCS_REFERENCED)
+ || ( ccs->indexTable != NULL )
+ || specialCCS(ccs)
+ || ccs->scc_count
+ || ccs->time_ticks
+ || ccs->mem_alloc) {
+ clearCCSBitFlag(ccs, CCS_REFERENCED);
+ return ccs;
+ } else {
+ return NULL;
}
- old_objects = NULL;
}
+//
+// Remove from the global CC_LIST all CostCentres which are statically allocated
+// in an unloaded object that we are about to free in this GC cycle.
+//
+static void gcCostCentres(OCSectionIndices *s_indices)
+{
+ CostCentre *cc, *prev, *next;
+ ObjectCode *oc;
+ prev = NULL;
+ for (cc = CC_LIST; cc != NULL; cc = next) {
+ next = cc->link;
+ oc = findOC(s_indices, cc);
+ if (oc != NULL && oc->referenced == 0) {
+ if (prev == NULL) {
+ CC_LIST = cc->link;
+ } else {
+ prev->link = cc->link;
+ }
+ } else {
+ prev = cc;
+ }
+ }
+}
+#endif
+
+// 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.
+#if defined(PROFILING)
+static void pruneUnreferencedObjs (OCSectionIndices *s_indices)
+#else /* PROFILING */
+static void pruneUnreferencedObjs (void)
+#endif /* PROFILING */
+{
+ ObjectCode *oc, *prev, *next;
+ prev = NULL;
+
+#if defined(PROFILING)
+ // At this point, we know what object should be unloaded based on the
+ // referenced field in its metadata ObjetCode* struct. Thus, we can traverse
+ // CC_LIST to prune CCs that belong to one of the unloaded objects.
+ gcCostCentres(s_indices);
+#endif /* PROFILING */
+
+ for (oc = unloaded_objects; oc; oc = next) {
+ next = oc->next;
+ if (oc->referenced == 0) {
+ if (prev == NULL) {
+ unloaded_objects = oc->next;
+ } else {
+ prev->next = oc->next;
+ }
+
+ IF_DEBUG(linker, debugBelch("Unloading object file %" PATH_FMT "\n",
+ oc->fileName));
+ freeObjectCode(oc);
+ } else {
+ IF_DEBUG(linker, debugBelch("Object file still in use: %"
+ PATH_FMT "\n", oc->fileName));
+ prev = oc;
+ }
+ }
+}
+
+// Look through the unloadable native objects, and any object that is still
+// marked as unreferenced can be physically unloaded, because we
+// have no references to it.
+static void pruneUnreferencedNativeObjs (void)
+{
+ NativeCode *nc, *prev, *next;
+ prev = NULL;
+ for (nc = unloaded_native_objects; nc; nc = next) {
+ next = nc->next;
+ if (nc->referenced == 0) {
+ if (prev == NULL) {
+ unloaded_native_objects = nc->next;
+ } else {
+ prev->next = nc->next;
+ }
+ IF_DEBUG(linker, debugBelch("Unloading object file %" PATH_FMT "\n",
+ nc->fileName));
+ IF_DEBUG(linker, debugBelch("Object file still in use: %"
+ PATH_FMT "\n", nc->fileName));
+ freeNativeCode(nc);
+ } else {
+ IF_DEBUG(linker, debugBelch("Object file still in use: %p\n",
+ nc->handle));
+ prev = nc;
+ }
+ }
+}
+
+//
+// Check whether we can unload any object code. This is called at the
+// appropriate point during a GC, where all the heap data is nice and
+// packed together and we have a linked list of the static objects.
+//
+// The check involves a complete heap traversal, but you only pay for
+// this (a) when you have called unloadObj(), and (b) at a major GC,
+// which is much more expensive than the traversal we're doing here.
+//
+void checkUnload (StgClosure *static_objects)
+{
+ uint32_t g, n;
+ HashTable *addrs;
+ StgClosure* p;
+ const StgInfoTable *info;
+ ObjectCode *oc;
+ NativeCode *nc;
+ gen_workspace *ws;
+ StgClosure* link;
+
+ if (unloaded_objects == NULL && unloaded_native_objects == NULL) return;
+
+ 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",
+ oc->fileName));
+ oc->referenced = false;
+ }
+
+ for (nc = unloaded_native_objects; nc; nc = nc->next) {
+ IF_DEBUG(linker, debugBelch("Checking whether to unload %" PATH_FMT "\n",
+ nc->fileName));
+ nc->referenced = false;
+ }
+
+ addrs = allocHashTable();
+
+ for (p = static_objects; p != END_OF_STATIC_OBJECT_LIST; p = link) {
+ p = UNTAG_STATIC_LIST_PTR(p);
+ checkAddress(addrs, p, s_indices);
+ info = get_itbl(p);
+ checkAddress(addrs, info, s_indices);
+ link = *STATIC_LINK(info, p);
+ }
+
+ // CAFs on revertible_caf_list are not on static_objects
+ for (p = (StgClosure*)revertible_caf_list;
+ p != END_OF_CAF_LIST;
+ p = ((StgIndStatic *)p)->static_link) {
+ p = UNTAG_STATIC_LIST_PTR(p);
+ checkAddress(addrs, p, s_indices);
+ }
+
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ 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, 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 */
+ // searchHeapBlocks marked CCSs which are referenced by the heap, so we can
+ // garbage collect the CCS tree
+ gcCostCentreStacks(CCS_MAIN);
+
+ // The cost centre tree now only contains CCSs kept alive by the heap.
+ // Traverse it and mark the owning objects as referenced.
+ searchCostCentres(addrs, CCS_MAIN, s_indices);
+
+#endif /* PROFILING */
+
+#if defined(PROFILING)
+ pruneUnreferencedObjs(s_indices);
+#else /* PROFILING */
+ pruneUnreferencedObjs();
+#endif /* PROFILING */
+ pruneUnreferencedNativeObjs();
+ freeOCSectionIndices(s_indices);
+
+ freeHashTable(addrs, NULL);
+
+ RELEASE_LOCK(&linker_unloaded_mutex);
+}
diff --git a/rts/CheckUnload.h b/rts/CheckUnload.h
index 7742b25452..ab85ead852 100644
--- a/rts/CheckUnload.h
+++ b/rts/CheckUnload.h
@@ -12,34 +12,6 @@
#include "BeginPrivate.h"
-#include "LinkerInternals.h"
-
-// Currently live objects
-extern ObjectCode *objects;
-
-// Root set for object collection
-extern ObjectCode *loaded_objects;
-
-// Mark bit for live objects
-extern uint8_t object_code_mark_bit;
-
-// Number of object code currently marked for unloading. See the definition in
-// CheckUnload.c for details.
-extern int n_unloaded_objects;
-
-void initUnloadCheck(void);
-void exitUnloadCheck(void);
-
-// Call before major GC to prepare section index table for marking
-void prepareUnloadCheck(void);
-
-// Mark object code of a static closure address as 'live'
-void markObjectCode(const void *addr);
-
-// Call after major GC to unload unused and unmarked object code
-void checkUnload(void);
-
-// Call on loaded object code
-void insertOCSectionIndices(ObjectCode *oc);
+void checkUnload (StgClosure *static_objects);
#include "EndPrivate.h"
diff --git a/rts/Hash.c b/rts/Hash.c
index e20fe52ba0..658187b944 100644
--- a/rts/Hash.c
+++ b/rts/Hash.c
@@ -109,6 +109,7 @@ compareStr(StgWord key1, StgWord key2)
return (strcmp((char *)key1, (char *)key2) == 0);
}
+
/* -----------------------------------------------------------------------------
* Allocate a new segment of the dynamically growing hash table.
* -------------------------------------------------------------------------- */
@@ -399,27 +400,6 @@ mapHashTable(HashTable *table, void *data, MapHashFn fn)
}
}
-void
-iterHashTable(HashTable *table, void *data, IterHashFn fn)
-{
- /* The last bucket with something in it is table->max + table->split - 1 */
- long segment = (table->max + table->split - 1) / HSEGSIZE;
- long index = (table->max + table->split - 1) % HSEGSIZE;
-
- while (segment >= 0) {
- while (index >= 0) {
- for (HashList *hl = table->dir[segment][index]; hl != NULL; hl = hl->next) {
- if (!fn(data, hl->key, hl->data)) {
- return;
- }
- }
- index--;
- }
- segment--;
- index = HSEGSIZE - 1;
- }
-}
-
/* -----------------------------------------------------------------------------
* When we initialize a hash table, we set up the first segment as well,
* initializing all of the first segment's hash buckets to NULL.
@@ -464,6 +444,12 @@ allocStrHashTable(void)
return allocHashTable_(hashStr, compareStr);
}
+void
+exitHashTable(void)
+{
+ /* nothing to do */
+}
+
int keyCountHashTable (HashTable *table)
{
return table->kcount;
diff --git a/rts/Hash.h b/rts/Hash.h
index b4ebe0b84d..be388fb62f 100644
--- a/rts/Hash.h
+++ b/rts/Hash.h
@@ -18,7 +18,7 @@ typedef struct hashtable HashTable; /* abstract */
* `const` so that calling function can mutate what the pointer points to if it
* needs to.
*/
-HashTable * allocHashTable ( void );
+HashTable * allocHashTable ( void );
void insertHashTable ( HashTable *table, StgWord key, const void *data );
void * lookupHashTable ( const HashTable *table, StgWord key );
void * removeHashTable ( HashTable *table, StgWord key, const void *data );
@@ -33,11 +33,8 @@ int keyCountHashTable (HashTable *table);
int keysHashTable(HashTable *table, StgWord keys[], int szKeys);
typedef void (*MapHashFn)(void *data, StgWord key, const void *value);
-// Return true -> continue; false -> stop
-typedef bool (*IterHashFn)(void *data, StgWord key, const void *value);
void mapHashTable(HashTable *table, void *data, MapHashFn fn);
-void iterHashTable(HashTable *table, void *data, IterHashFn);
/* Hash table access where the keys are C strings (the strings are
* assumed to be allocated by the caller, and mustn't be deallocated
@@ -46,13 +43,13 @@ void iterHashTable(HashTable *table, void *data, IterHashFn);
HashTable * allocStrHashTable ( void );
#define lookupStrHashTable(table, key) \
- (lookupHashTable(table, (StgWord)key))
+ (lookupHashTable(table, (StgWord)key))
#define insertStrHashTable(table, key, data) \
- (insertHashTable(table, (StgWord)key, data))
+ (insertHashTable(table, (StgWord)key, data))
#define removeStrHashTable(table, key, data) \
- (removeHashTable(table, (StgWord)key, data))
+ (removeHashTable(table, (StgWord)key, data))
/* Hash tables for arbitrary keys */
typedef int HashFunction(const HashTable *table, StgWord key);
@@ -65,27 +62,6 @@ int hashStr(const HashTable *table, StgWord key);
*/
void freeHashTable ( HashTable *table, void (*freeDataFun)(void *) );
-/*
- * Hash set API
- *
- * A hash set is bascially a hash table where values are NULL.
- */
-
-typedef struct hashtable HashSet;
-
-INLINE_HEADER HashSet *allocHashSet ( void )
-{
- return (HashSet*)allocHashTable();
-}
-
-INLINE_HEADER void freeHashSet ( HashSet *set )
-{
- freeHashTable((HashTable*)set, NULL);
-}
-
-INLINE_HEADER void insertHashSet ( HashSet *set, StgWord key )
-{
- insertHashTable((HashTable*)set, key, NULL);
-}
+void exitHashTable ( void );
#include "EndPrivate.h"
diff --git a/rts/Linker.c b/rts/Linker.c
index a34c9e7322..329eaf0986 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -31,7 +31,6 @@
#include "linker/CacheFlush.h"
#include "linker/SymbolExtras.h"
#include "PathUtils.h"
-#include "CheckUnload.h" // createOCSectionIndices
#if !defined(mingw32_HOST_OS)
#include "posix/Signals.h"
@@ -162,16 +161,49 @@
*/
/*Str*/HashTable *symhash;
+/* List of currently loaded objects */
+ObjectCode *objects = NULL; /* initially empty */
+
+/* List of objects that have been unloaded via unloadObj(), but are waiting
+ to be actually freed via checkUnload() */
+ObjectCode *unloaded_objects = NULL; /* initially empty */
+
+/* List of currently loaded native objects */
+NativeCode *native_objects = NULL; /* initially empty */
+
+/* List of objects that have been unloaded via unloadNativeObj(),
+ but are waiting to be actually freed via checkUnload() */
+NativeCode *unloaded_native_objects = NULL; /* initially empty */
+
+/* List of objects that are waiting to be freed after being checked by
+ * CheckUnload() */
+NativeCode *to_free_native_objects = NULL; /* initially empty */
+
#if defined(THREADED_RTS)
-/* This protects all the Linker's global state */
+/* This protects all the Linker's global state except unloaded_objects
+ * and unloaded_native_objects */
Mutex linker_mutex;
+/*
+ * This protects unloaded_objects and unloaded_native_objects.
+ * We have a separate mutex for this, because the GC needs to access
+ * unloaded_objects and unloaded_native_objects. in checkUnload,
+ * while the linker only needs to access unloaded_objects and
+ * unloaded_native_objects in unloadObj(), so this allows most linker
+ * operations proceed concurrently with the GC.
+ */
+Mutex linker_unloaded_mutex;
+/*
+ * This protects native code that we want to free from freeNativeCode.
+ * We want a separate mutex here so that we are able to queue up freeNativeCode_
+ * calls while a long dlopen is taking place, and then free them after
+ * unlocking the mutex.
+ */
+Mutex free_native_code_mutex;
#endif
/* Generic wrapper function to try and Resolve and RunInit oc files */
int ocTryLoad( ObjectCode* oc );
-static void freeNativeCode_ELF (ObjectCode *nc);
-
/* Link objects into the lower 2Gb on x86_64. GHC assumes the
* small memory model on this architecture (see gcc docs,
* -mcmodel=small).
@@ -416,10 +448,16 @@ initLinker_ (int retain_cafs)
linker_init_done = 1;
}
- initUnloadCheck();
+ objects = NULL;
+ unloaded_objects = NULL;
+
+ native_objects = NULL;
+ unloaded_native_objects = NULL;
#if defined(THREADED_RTS)
initMutex(&linker_mutex);
+ initMutex(&linker_unloaded_mutex);
+ initMutex(&free_native_code_mutex);
#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
initMutex(&dl_mutex);
#endif
@@ -510,8 +548,6 @@ exitLinker( void ) {
#endif
if (linker_init_done == 1) {
freeHashTable(symhash, free);
-
- exitUnloadCheck();
}
#if defined(THREADED_RTS)
closeMutex(&linker_mutex);
@@ -810,24 +846,18 @@ HsInt insertSymbol(pathchar* obj_name, SymbolName* key, SymbolAddr* data)
}
/* -----------------------------------------------------------------------------
- * Lookup a symbol in the hash table
- *
- * When 'dependent' is not NULL, adds it as a dependent to the owner of the
- * symbol.
+ * lookup a symbol in the hash table
*/
#if defined(OBJFORMAT_PEi386)
-SymbolAddr* lookupDependentSymbol (SymbolName* lbl, ObjectCode *dependent)
+SymbolAddr* lookupSymbol_ (SymbolName* lbl)
{
- (void)dependent; // TODO
- ASSERT_LOCK_HELD(&linker_mutex);
return lookupSymbol_PEi386(lbl);
}
#else
-SymbolAddr* lookupDependentSymbol (SymbolName* lbl, ObjectCode *dependent)
+SymbolAddr* lookupSymbol_ (SymbolName* lbl)
{
- ASSERT_LOCK_HELD(&linker_mutex);
IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s\n", lbl));
ASSERT(symhash != NULL);
@@ -852,18 +882,10 @@ SymbolAddr* lookupDependentSymbol (SymbolName* lbl, ObjectCode *dependent)
return internal_dlsym(lbl + 1);
# else
- ASSERT(false);
+ ASSERT(2+2 == 5);
return NULL;
# endif
} else {
- if (dependent) {
- // Add dependent as symbol's owner's dependency
- ObjectCode *owner = pinfo->owner;
- if (owner) {
- // TODO: what does it mean for a symbol to not have an owner?
- insertHashSet(dependent->dependencies, (W_)owner);
- }
- }
return loadSymbol(lbl, pinfo);
}
}
@@ -902,9 +924,7 @@ SymbolAddr* loadSymbol(SymbolName *lbl, RtsSymbolInfo *pinfo) {
SymbolAddr* lookupSymbol( SymbolName* lbl )
{
ACQUIRE_LOCK(&linker_mutex);
- // NULL for "don't add dependent". When adding a dependency we call
- // lookupDependentSymbol directly.
- SymbolAddr* r = lookupDependentSymbol(lbl, NULL);
+ SymbolAddr* r = lookupSymbol_(lbl);
if (!r) {
errorBelch("^^ Could not load '%s', dependency unresolved. "
"See top entry above.\n", lbl);
@@ -1162,16 +1182,6 @@ freePreloadObjectFile (ObjectCode *oc)
*/
void freeObjectCode (ObjectCode *oc)
{
- if (oc->type == DYNAMIC_OBJECT) {
-#if defined(OBJFORMAT_ELF)
- ACQUIRE_LOCK(&dl_mutex);
- freeNativeCode_ELF(oc);
- RELEASE_LOCK(&dl_mutex);
-#else
- barf("freeObjectCode: This shouldn't happen");
-#endif
- }
-
freePreloadObjectFile(oc);
if (oc->symbols != NULL) {
@@ -1195,7 +1205,11 @@ void freeObjectCode (ObjectCode *oc)
oc->sections[i].mapped_size);
break;
case SECTION_M32:
- // Freed by m32_allocator_free
+ IF_DEBUG(sanity,
+ memset(oc->sections[i].start,
+ 0x00, oc->sections[i].size));
+ m32_free(oc->sections[i].start,
+ oc->sections[i].size);
break;
#endif
case SECTION_MALLOC:
@@ -1242,8 +1256,6 @@ void freeObjectCode (ObjectCode *oc)
stgFree(oc->fileName);
stgFree(oc->archiveMemberName);
- freeHashSet(oc->dependencies);
-
stgFree(oc);
}
@@ -1265,7 +1277,7 @@ static void setOcInitialStatus(ObjectCode* oc) {
}
ObjectCode*
-mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
+mkOc( pathchar *path, char *image, int imageSize,
bool mapped, char *archiveMemberName, int misalignment ) {
ObjectCode* oc;
@@ -1273,7 +1285,6 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
oc = stgMallocBytes(sizeof(ObjectCode), "mkOc(oc)");
oc->info = NULL;
- oc->type = type;
# if defined(OBJFORMAT_ELF)
oc->formatName = "ELF";
@@ -1317,14 +1328,6 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
/* chain it onto the list of objects */
oc->next = NULL;
- oc->prev = NULL;
- oc->next_loaded_object = NULL;
- oc->mark = object_code_mark_bit;
- oc->dependencies = allocHashSet();
-
- oc->l_addr = NULL;
- oc->nc_ranges = NULL;
- oc->dlopen_handle = NULL;
IF_DEBUG(linker, debugBelch("mkOc: done\n"));
return oc;
@@ -1338,7 +1341,8 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
HsInt
isAlreadyLoaded( pathchar *path )
{
- for (ObjectCode *o = objects; o; o = o->next) {
+ ObjectCode *o;
+ for (o = objects; o; o = o->next) {
if (0 == pathcmp(o->fileName, path)) {
return 1; /* already loaded */
}
@@ -1450,7 +1454,7 @@ preloadObjectFile (pathchar *path)
#endif /* RTS_LINKER_USE_MMAP */
- oc = mkOc(STATIC_OBJECT, path, image, fileSize, true, NULL, misalignment);
+ oc = mkOc(path, image, fileSize, true, NULL, misalignment);
#if defined(OBJFORMAT_MACHO)
if (ocVerifyImage_MachO( oc ))
@@ -1470,17 +1474,21 @@ preloadObjectFile (pathchar *path)
*/
static HsInt loadObj_ (pathchar *path)
{
+ ObjectCode* oc;
+ IF_DEBUG(linker, debugBelch("loadObj %" PATH_FMT "\n", path));
+
+ /* debugBelch("loadObj %s\n", path ); */
- // Check that we haven't already loaded this object.
- // Ignore requests to load multiple times
+ /* Check that we haven't already loaded this object.
+ Ignore requests to load multiple times */
if (isAlreadyLoaded(path)) {
IF_DEBUG(linker,
debugBelch("ignoring repeated load of %" PATH_FMT "\n", path));
- return 1; // success
+ return 1; /* success */
}
- ObjectCode *oc = preloadObjectFile(path);
+ oc = preloadObjectFile(path);
if (oc == NULL) return 0;
if (! loadOc(oc)) {
@@ -1491,10 +1499,8 @@ static HsInt loadObj_ (pathchar *path)
return 0;
}
- insertOCSectionIndices(oc);
-
- oc->next_loaded_object = loaded_objects;
- loaded_objects = oc;
+ oc->next = objects;
+ objects = oc;
return 1;
}
@@ -1665,10 +1671,13 @@ int ocTryLoad (ObjectCode* oc) {
*/
static HsInt resolveObjs_ (void)
{
+ ObjectCode *oc;
+ int r;
+
IF_DEBUG(linker, debugBelch("resolveObjs: start\n"));
- for (ObjectCode *oc = objects; oc; oc = oc->next) {
- int r = ocTryLoad(oc);
+ for (oc = objects; oc; oc = oc->next) {
+ r = ocTryLoad(oc);
if (!r)
{
return r;
@@ -1697,35 +1706,45 @@ HsInt resolveObjs (void)
*/
static HsInt unloadObj_ (pathchar *path, bool just_purge)
{
+ ObjectCode *oc, *prev, *next;
+ HsBool unloadedAnyObj = HS_BOOL_FALSE;
+
ASSERT(symhash != NULL);
ASSERT(objects != NULL);
IF_DEBUG(linker, debugBelch("unloadObj: %" PATH_FMT "\n", path));
- bool unloadedAnyObj = false;
- ObjectCode *prev = NULL;
- // NOTE (osa): There may be more than one object with the same file name
- // (happens when loading archive files) so we don't stop after unloading one
- for (ObjectCode *oc = loaded_objects; oc; oc = oc->next_loaded_object) {
- if (pathcmp(oc->fileName,path) == 0) {
- oc->status = OBJECT_UNLOADED;
+ prev = NULL;
+ for (oc = objects; oc; oc = next) {
+ next = oc->next; // oc might be freed
- // These are both idempotent, so in just_purge mode we can later
- // call unloadObj() to really unload the object.
+ if (!pathcmp(oc->fileName,path)) {
+
+ // these are both idempotent, so in just_purge mode we can
+ // later call unloadObj() to really unload the object.
removeOcSymbols(oc);
freeFEStablePtrs(&oc->stable_ptrs);
- unloadedAnyObj = true;
-
if (!just_purge) {
- n_unloaded_objects += 1;
- // Remove object code from root set
if (prev == NULL) {
- loaded_objects = oc->next_loaded_object;
+ objects = oc->next;
} else {
- prev->next_loaded_object = oc->next_loaded_object;
+ prev->next = oc->next;
}
+ ACQUIRE_LOCK(&linker_unloaded_mutex);
+ oc->next = unloaded_objects;
+ unloaded_objects = oc;
+ oc->status = OBJECT_UNLOADED;
+ RELEASE_LOCK(&linker_unloaded_mutex);
+ // We do not own oc any more; it can be released at any time by
+ // the GC in checkUnload().
+ } else {
+ prev = oc;
}
+
+ /* This could be a member of an archive so continue
+ * unloading other members. */
+ unloadedAnyObj = HS_BOOL_TRUE;
} else {
prev = oc;
}
@@ -1733,7 +1752,8 @@ static HsInt unloadObj_ (pathchar *path, bool just_purge)
if (unloadedAnyObj) {
return 1;
- } else {
+ }
+ else {
errorBelch("unloadObj: can't find `%" PATH_FMT "' to unload", path);
return 0;
}
@@ -1757,7 +1777,13 @@ HsInt purgeObj (pathchar *path)
static OStatus getObjectLoadStatus_ (pathchar *path)
{
- for (ObjectCode *o = objects; o; o = o->next) {
+ ObjectCode *o;
+ for (o = objects; o; o = o->next) {
+ if (0 == pathcmp(o->fileName, path)) {
+ return o->status;
+ }
+ }
+ for (o = unloaded_objects; o; o = o->next) {
if (0 == pathcmp(o->fileName, path)) {
return o->status;
}
@@ -1845,10 +1871,11 @@ addSection (Section *s, SectionKind kind, SectionAlloc alloc,
size, kind ));
}
+
# if defined(OBJFORMAT_ELF)
static int loadNativeObjCb_(struct dl_phdr_info *info,
size_t _size GNUC3_ATTRIBUTE(__unused__), void *data) {
- ObjectCode* nc = (ObjectCode*) data;
+ NativeCode* nc = (NativeCode*) data;
// This logic mimicks _dl_addr_inside_object from glibc
// For reference:
@@ -1891,8 +1918,8 @@ static void copyErrmsg(char** errmsg_dest, char* errmsg) {
}
// need dl_mutex
-static void freeNativeCode_ELF (ObjectCode *nc) {
- dlclose(nc->dlopen_handle);
+static void freeNativeCode_ELF (NativeCode *nc) {
+ dlclose(nc->handle);
NativeCodeRange *ncr = nc->nc_ranges;
while (ncr) {
@@ -1900,15 +1927,38 @@ static void freeNativeCode_ELF (ObjectCode *nc) {
ncr = ncr->next;
stgFree(last_ncr);
}
+ freeFEStablePtrs(&nc->stable_ptrs);
+ stgFree(nc->fileName);
+ stgFree(nc);
}
static void * loadNativeObj_ELF (pathchar *path, char **errmsg)
{
- ObjectCode* nc;
+ NativeCode* nc;
void *hdl, *retval;
IF_DEBUG(linker, debugBelch("loadNativeObj_ELF %" PATH_FMT "\n", path));
+ // Loading the same object multiple times will lead to chaos
+ // because we will have two NativeCodes but one underlying handle,
+ // so let's fail if this happens.
+ for (nc = native_objects; nc; nc = nc->next) {
+ if (!pathcmp(nc->fileName,path)) {
+ copyErrmsg(errmsg, "native object already loaded");
+ return NULL;
+ }
+ }
+
+ // We also cannot load the same object if we are in the process of
+ // unloading it. We cannot resurrect it because we've already
+ // released the StablePtrs.
+ for (nc = unloaded_native_objects; nc; nc = nc->next) {
+ if (!pathcmp(nc->fileName,path)) {
+ copyErrmsg(errmsg, "unload in progress");
+ return NULL;
+ }
+ }
+
retval = NULL;
ACQUIRE_LOCK(&dl_mutex);
@@ -1931,12 +1981,15 @@ static void * loadNativeObj_ELF (pathchar *path, char **errmsg)
goto dlinfo_fail;
}
- nc = mkOc(DYNAMIC_OBJECT, path, NULL, 0, true, NULL, 0);
+ nc = stgMallocBytes(sizeof(NativeCode), "loadNativeObj_ELF");
nc->l_addr = (void*) map->l_addr;
- nc->dlopen_handle = hdl;
+ nc->nc_ranges = NULL;
+ nc->handle = hdl;
+ nc->fileName = pathdup(path);
hdl = NULL; // pass handle ownership to nc
nc->stable_ptrs = fe_sptr;
fe_sptr = NULL; // pass the ownership to nc
+ nc->referenced = 0;
dl_iterate_phdr(loadNativeObjCb_, nc);
if (!nc->nc_ranges) {
@@ -1944,12 +1997,10 @@ static void * loadNativeObj_ELF (pathchar *path, char **errmsg)
goto dl_iterate_phdr_fail;
}
- insertOCSectionIndices(nc);
+ nc->next = native_objects;
+ native_objects = nc;
- nc->next_loaded_object = loaded_objects;
- loaded_objects = nc;
-
- retval = nc->dlopen_handle;
+ retval = nc->handle;
goto success;
dl_iterate_phdr_fail:
@@ -1962,57 +2013,39 @@ dlopen_fail:
success:
RELEASE_LOCK(&dl_mutex);
- IF_DEBUG(linker, debugBelch("loadNativeObj_ELF result=%p\n", retval));
return retval;
}
-# endif
-
-#define UNUSED(x) (void)(x)
-
-void * loadNativeObj (pathchar *path, char **errmsg)
+static HsInt unloadNativeObj_ELF (void *handle)
{
-#if defined(OBJFORMAT_ELF)
- ACQUIRE_LOCK(&linker_mutex);
- void *r = loadNativeObj_ELF(path, errmsg);
- RELEASE_LOCK(&linker_mutex);
- return r;
-#else
- UNUSED(path);
- UNUSED(errmsg);
- barf("loadNativeObj: not implemented on this platform");
-#endif
-}
+ NativeCode *nc, *prev, *next;
+ HsBool unloadedAnyObj = HS_BOOL_FALSE;
-HsInt unloadNativeObj (void *handle)
-{
- bool unloadedAnyObj = false;
+ ASSERT(native_objects != NULL);
IF_DEBUG(linker, debugBelch("unloadNativeObj: %p\n", handle));
- ObjectCode *prev = NULL, *next;
- for (ObjectCode *nc = loaded_objects; nc; nc = next) {
- next = nc->next_loaded_object; // we might move nc
- if (nc->type == DYNAMIC_OBJECT && nc->dlopen_handle == handle) {
- nc->status = OBJECT_UNLOADED;
- n_unloaded_objects += 1;
+ prev = NULL;
+ for (nc = native_objects; nc; nc = next) {
+ next = nc->next; // we might move nc
- // dynamic objects have no symbols
- ASSERT(nc->symbols == NULL);
+ if (nc->handle == handle) {
freeFEStablePtrs(&nc->stable_ptrs);
-
- // Remove object code from root set
if (prev == NULL) {
- loaded_objects = nc->next_loaded_object;
+ native_objects = nc->next;
} else {
- prev->next_loaded_object = nc->next_loaded_object;
+ prev->next = nc->next;
}
- unloadedAnyObj = true;
+ ACQUIRE_LOCK(&linker_unloaded_mutex);
+ nc->next = unloaded_native_objects;
+ unloaded_native_objects = nc;
+ RELEASE_LOCK(&linker_unloaded_mutex);
} else {
prev = nc;
}
+ unloadedAnyObj = HS_BOOL_TRUE;
}
if (unloadedAnyObj) {
@@ -2022,4 +2055,99 @@ HsInt unloadNativeObj (void *handle)
return 0;
}
}
+# endif
+
+#define UNUSED(x) (void)(x)
+HsInt unloadNativeObj (void *handle)
+{
+#if defined(OBJFORMAT_ELF)
+ ACQUIRE_LOCK(&linker_mutex);
+ HsInt r = unloadNativeObj_ELF(handle);
+ RELEASE_LOCK(&linker_mutex);
+ return r;
+#else
+ UNUSED(handle);
+ barf("unloadNativeObj: not implemented on this platform");
+#endif
+}
+
+static void freeNativeCode_ ( NativeCode *nc )
+{
+ ASSERT_LOCK_HELD(&dl_mutex);
+#if defined(OBJFORMAT_ELF)
+ freeNativeCode_ELF(nc);
+#else
+ UNUSED(nc);
+ // no op
+ return;
+#endif
+}
+
+static void tryFreeNativeCode ( void )
+{
+ NativeCode *nc, *next;
+
+ while (true) {
+ ACQUIRE_LOCK(&free_native_code_mutex);
+ nc = to_free_native_objects;
+ to_free_native_objects = NULL;
+ RELEASE_LOCK(&free_native_code_mutex);
+ if (nc == NULL) {
+ return;
+ }
+ #if defined(THREADED_RTS)
+ if (TRY_ACQUIRE_LOCK(&dl_mutex) != 0) {
+ IF_DEBUG(linker, debugBelch("Unable to acquire dl lock, not pruning"
+ "native objs."));
+ ACQUIRE_LOCK(&free_native_code_mutex);
+ // re-add this to the list
+ nc->next = to_free_native_objects;
+ to_free_native_objects = nc;
+ RELEASE_LOCK(&free_native_code_mutex);
+ return;
+ }
+ #endif
+
+ while (nc) {
+ next = nc->next;
+ freeNativeCode_(nc);
+ nc = next;
+ }
+ RELEASE_LOCK(&dl_mutex);
+ }
+}
+
+void * loadNativeObj (pathchar *path, char **errmsg)
+{
+#if defined(OBJFORMAT_ELF)
+ ACQUIRE_LOCK(&linker_mutex);
+ void *r = loadNativeObj_ELF(path, errmsg);
+ RELEASE_LOCK(&linker_mutex);
+ return r;
+
+#if defined(PROFILING)
+ // collect any new cost centres & CCSs that were defined during runInit
+ initProfiling2();
+#endif
+
+ // If we are calling loadNativeObj a lot we may build up a queue of objects
+ // to clean up, so do that here at the very least to prevent the caller of
+ // this to grow memory unboundedly.
+ tryFreeNativeCode();
+
+#else
+ UNUSED(path);
+ UNUSED(errmsg);
+ barf("loadNativeObj: not implemented on this platform");
+#endif
+}
+
+void freeNativeCode (NativeCode *nc)
+{
+ ACQUIRE_LOCK(&free_native_code_mutex);
+ nc->next = to_free_native_objects;
+ to_free_native_objects = nc;
+ RELEASE_LOCK(&free_native_code_mutex);
+ tryFreeNativeCode();
+}
diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h
index 14050f8641..7ad6387bd3 100644
--- a/rts/LinkerInternals.h
+++ b/rts/LinkerInternals.h
@@ -28,13 +28,6 @@ typedef struct _Symbol
SymbolAddr *addr;
} Symbol_t;
-typedef struct NativeCodeRange_ {
- void *start, *end;
-
- /* Allow a chain of these things */
- struct NativeCodeRange_ *next;
-} NativeCodeRange;
-
/* Indication of section kinds for loaded objects. Needed by
the GC for deciding whether or not a pointer on the stack
is a code pointer.
@@ -144,13 +137,6 @@ typedef struct {
#endif
} SymbolExtra;
-typedef enum {
- /* Objects that were loaded by this linker */
- STATIC_OBJECT,
-
- /* Objects that were loaded by dlopen */
- DYNAMIC_OBJECT,
-} ObjectType;
/* Top-level structure for an object module. One of these is allocated
* for each object file in use.
@@ -159,8 +145,7 @@ typedef struct _ObjectCode {
OStatus status;
pathchar *fileName;
int fileSize; /* also mapped image size when using mmap() */
- char* formatName; /* e.g. "ELF32", "DLL", "COFF", etc. */
- ObjectType type; /* who loaded this object? */
+ char* formatName; /* eg "ELF32", "DLL", "COFF", etc. */
/* If this object is a member of an archive, archiveMemberName is
* like "libarchive.a(object.o)". Otherwise it's NULL.
@@ -185,6 +170,9 @@ typedef struct _ObjectCode {
/* non-zero if the object file was mmap'd, otherwise malloc'd */
int imageMapped;
+ /* flag used when deciding whether to unload an object file */
+ int referenced;
+
/* record by how much image has been deliberately misaligned
after allocation, so that we can use realloc */
int misalignment;
@@ -194,37 +182,8 @@ typedef struct _ObjectCode {
int n_sections;
Section* sections;
- //
- // Garbage collection fields
- //
-
- // Next object in `objects` list
- struct _ObjectCode *next;
-
- // Previous object in `objects` list
- struct _ObjectCode *prev;
-
- // Next object in `loaded_objects` list
- struct _ObjectCode *next_loaded_object;
-
- // Mark bit
- uint8_t mark;
-
- // Set of dependencies (ObjectCode*) of the object file. Traverse
- // dependencies using `iterHashTable`.
- //
- // New entries are added as we resolve symbols in an object file, in
- // `lookupDependentSymbol`. When an object file uses multiple symbols from
- // another object file we add the dependent multiple times, so we use a
- // `HashTable` here rather than a list/array to avoid copies.
- //
- // Used when unloading object files. See Note [Object unloading] in
- // CheckUnload.c.
- HashSet *dependencies;
-
- //
- // End of garbage collection fields
- //
+ /* Allow a chain of these things */
+ struct _ObjectCode * next;
/* SANITY CHECK ONLY: a list of the only memory regions which may
safely be prodded during relocation. Any attempt to prod
@@ -253,18 +212,6 @@ typedef struct _ObjectCode {
require extra information.*/
HashTable *extraInfos;
- /*
- * The following are only valid if .type == DYNAMIC_OBJECT
- */
-
- /* handle returned from dlopen */
- void *dlopen_handle;
-
- /* base virtual address of the loaded code */
- void *l_addr;
-
- /* virtual memory ranges of loaded code */
- NativeCodeRange *nc_ranges;
} ObjectCode;
#define OC_INFORMATIVE_FILENAME(OC) \
@@ -273,6 +220,20 @@ typedef struct _ObjectCode {
(OC)->fileName \
)
+extern ObjectCode *objects;
+extern ObjectCode *unloaded_objects;
+
+typedef struct NativeCodeRange_ {
+
+ void *start;
+
+ void *end;
+
+ /* Allow a chain of these things */
+ struct NativeCodeRange_ *next;
+
+} NativeCodeRange;
+
typedef struct NativeCode_ {
pathchar *fileName;
@@ -301,6 +262,7 @@ extern NativeCode *unloaded_native_objects;
#if defined(THREADED_RTS)
extern Mutex linker_mutex;
+extern Mutex linker_unloaded_mutex;
#endif
/* Type of the initializer */
@@ -351,9 +313,8 @@ int ghciInsertSymbolTable(
HsBool weak,
ObjectCode *owner);
-/* Lock-free version of lookupSymbol. When 'dependent' is not NULL, adds it as a
- * dependent to the owner of the symbol. */
-SymbolAddr* lookupDependentSymbol (SymbolName* lbl, ObjectCode *dependent);
+/* lock-free version of lookupSymbol */
+SymbolAddr* lookupSymbol_ (SymbolName* lbl);
extern /*Str*/HashTable *symhash;
@@ -384,7 +345,7 @@ resolveSymbolAddr (pathchar* buffer, int size,
HsInt isAlreadyLoaded( pathchar *path );
HsInt loadOc( ObjectCode* oc );
-ObjectCode* mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
+ObjectCode* mkOc( pathchar *path, char *image, int imageSize,
bool mapped, char *archiveMemberName,
int misalignment
);
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index be51119d35..5e5aef3505 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -495,6 +495,9 @@ hs_exit_(bool wait_foreign)
shutdownAsyncIO(wait_foreign);
#endif
+ /* free hash table storage */
+ exitHashTable();
+
// Finally, free all our storage. However, we only free the heap
// memory if we have waited for foreign calls to complete;
// otherwise a foreign call in progress may still be referencing
diff --git a/rts/linker/Elf.c b/rts/linker/Elf.c
index 69add65b2f..6471761428 100644
--- a/rts/linker/Elf.c
+++ b/rts/linker/Elf.c
@@ -1064,7 +1064,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
if (ELF_ST_BIND(symbol->elf_sym->st_info) == STB_LOCAL || strncmp(symbol->name, "_GLOBAL_OFFSET_TABLE_", 21) == 0) {
S = (Elf_Addr)symbol->addr;
} else {
- S_tmp = lookupDependentSymbol( symbol->name, oc );
+ S_tmp = lookupSymbol_( symbol->name );
S = (Elf_Addr)S_tmp;
}
if (!S) {
@@ -1484,7 +1484,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
} else {
/* No, so look up the name in our global table. */
symbol = strtab + sym.st_name;
- S_tmp = lookupDependentSymbol( symbol, oc );
+ S_tmp = lookupSymbol_( symbol );
S = (Elf_Addr)S_tmp;
}
if (!S) {
diff --git a/rts/linker/LoadArchive.c b/rts/linker/LoadArchive.c
index a531eb7cea..d03b416f1e 100644
--- a/rts/linker/LoadArchive.c
+++ b/rts/linker/LoadArchive.c
@@ -5,7 +5,6 @@
#include "sm/OSMem.h"
#include "RtsUtils.h"
#include "LinkerInternals.h"
-#include "CheckUnload.h" // loaded_objects, insertOCSectionIndices
#include "linker/M32Alloc.h"
/* Platform specific headers */
@@ -242,6 +241,7 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_,
static HsInt loadArchive_ (pathchar *path)
{
+ ObjectCode* oc = NULL;
char *image = NULL;
HsInt retcode = 0;
int memberSize;
@@ -519,8 +519,8 @@ static HsInt loadArchive_ (pathchar *path)
sprintf(archiveMemberName, "%" PATH_FMT "(%.*s)",
path, (int)thisFileNameSize, fileName);
- ObjectCode *oc = mkOc(STATIC_OBJECT, path, image, memberSize, false, archiveMemberName,
- misalignment);
+ oc = mkOc(path, image, memberSize, false, archiveMemberName
+ , misalignment);
#if defined(OBJFORMAT_MACHO)
ocInit_MachO( oc );
#endif
@@ -535,9 +535,8 @@ static HsInt loadArchive_ (pathchar *path)
fclose(f);
return 0;
} else {
- insertOCSectionIndices(oc); // also adds the object to `objects` list
- oc->next_loaded_object = loaded_objects;
- loaded_objects = oc;
+ oc->next = objects;
+ objects = oc;
}
}
else if (isGnuIndex) {
diff --git a/rts/linker/MachO.c b/rts/linker/MachO.c
index 22476a5519..ca5befca77 100644
--- a/rts/linker/MachO.c
+++ b/rts/linker/MachO.c
@@ -277,7 +277,7 @@ resolveImports(
addr = (SymbolAddr*) (symbol->nlist->n_value);
IF_DEBUG(linker, debugBelch("resolveImports: undefined external %s has value %p\n", symbol->name, addr));
} else {
- addr = lookupDependentSymbol(symbol->name, oc);
+ addr = lookupSymbol_(symbol->name);
IF_DEBUG(linker, debugBelch("resolveImports: looking up %s, %p\n", symbol->name, addr));
}
@@ -611,12 +611,12 @@ relocateSectionAarch64(ObjectCode * oc, Section * section)
uint64_t value = 0;
if(symbol->nlist->n_type & N_EXT) {
/* external symbols should be able to be
- * looked up via the lookupDependentSymbol function.
+ * looked up via the lookupSymbol_ function.
* Either through the global symbol hashmap
* or asking the system, if not found
* in the symbol hashmap
*/
- value = (uint64_t)lookupDependentSymbol((char*)symbol->name, oc);
+ value = (uint64_t)lookupSymbol_((char*)symbol->name);
if(!value)
barf("Could not lookup symbol: %s!", symbol->name);
} else {
@@ -656,7 +656,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section)
uint64_t pc = (uint64_t)section->start + ri->r_address;
uint64_t value = 0;
if(symbol->nlist->n_type & N_EXT) {
- value = (uint64_t)lookupDependentSymbol((char*)symbol->name, oc);
+ value = (uint64_t)lookupSymbol_((char*)symbol->name);
if(!value)
barf("Could not lookup symbol: %s!", symbol->name);
} else {
@@ -850,7 +850,7 @@ relocateSection(
// symtab, or it is undefined, meaning dlsym must be used
// to resolve it.
- addr = lookupDependentSymbol(nm, oc);
+ addr = lookupSymbol_(nm);
IF_DEBUG(linker, debugBelch("relocateSection: looked up %s, "
"external X86_64_RELOC_GOT or X86_64_RELOC_GOT_LOAD\n", nm));
IF_DEBUG(linker, debugBelch(" : addr = %p\n", addr));
@@ -902,7 +902,7 @@ relocateSection(
IF_DEBUG(linker, debugBelch("relocateSection, defined external symbol %s, relocated address %p\n", nm, (void *)value));
}
else {
- addr = lookupDependentSymbol(nm, oc);
+ addr = lookupSymbol_(nm);
if (addr == NULL)
{
errorBelch("\nlookupSymbol failed in relocateSection (relocate external)\n"
@@ -1423,7 +1423,7 @@ ocGetNames_MachO(ObjectCode* oc)
if(oc->info->nlist[i].n_type & N_EXT)
{
if ( (oc->info->nlist[i].n_desc & N_WEAK_DEF)
- && lookupDependentSymbol(nm, oc)) {
+ && lookupSymbol_(nm)) {
// weak definition, and we already have a definition
IF_DEBUG(linker, debugBelch(" weak: %s\n", nm));
}
@@ -1581,7 +1581,7 @@ ocResolve_MachO(ObjectCode* oc)
* have the address.
*/
if(NULL == symbol->addr) {
- symbol->addr = lookupDependentSymbol((char*)symbol->name, oc);
+ symbol->addr = lookupSymbol_((char*)symbol->name);
if(NULL == symbol->addr)
barf("Failed to lookup symbol: %s", symbol->name);
} else {
diff --git a/rts/linker/PEi386.c b/rts/linker/PEi386.c
index 35b35dd34d..20103084d0 100644
--- a/rts/linker/PEi386.c
+++ b/rts/linker/PEi386.c
@@ -1885,7 +1885,7 @@ ocResolve_PEi386 ( ObjectCode* oc )
} else {
copyName ( getSymShortName (info, sym), oc, symbol,
sizeof(symbol)-1 );
- S = (size_t) lookupDependentSymbol( (char*)symbol, oc );
+ S = (size_t) lookupSymbol_( (char*)symbol );
if ((void*)S == NULL) {
errorBelch(" | %" PATH_FMT ": unknown symbol `%s'", oc->fileName, symbol);
releaseOcInfo (oc);
diff --git a/rts/linker/elf_got.c b/rts/linker/elf_got.c
index 90ce41b909..5cb56cd2dc 100644
--- a/rts/linker/elf_got.c
+++ b/rts/linker/elf_got.c
@@ -85,7 +85,7 @@ fillGot(ObjectCode * oc) {
if( STT_NOTYPE == ELF_ST_TYPE(symbol->elf_sym->st_info)
|| STB_WEAK == ELF_ST_BIND(symbol->elf_sym->st_info)) {
if(0x0 == symbol->addr) {
- symbol->addr = lookupDependentSymbol(symbol->name, oc);
+ symbol->addr = lookupSymbol_(symbol->name);
if(0x0 == symbol->addr) {
if(0 == strncmp(symbol->name,"_GLOBAL_OFFSET_TABLE_",21)) {
symbol->addr = oc->info->got_start;
diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index ffcbf74762..f080221e28 100644
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -27,7 +27,6 @@
#include "LdvProfile.h"
#include "CNF.h"
#include "Scav.h"
-#include "CheckUnload.h" // n_unloaded_objects and markObjectCode
#if defined(THREADED_RTS) && !defined(PARALLEL_GC)
#define evacuate(p) evacuate1(p)
@@ -519,11 +518,6 @@ loop:
if (!HEAP_ALLOCED_GC(q)) {
if (!major_gc) return;
- // Note [Object unloading] in CheckUnload.c
- if (n_unloaded_objects != 0) {
- markObjectCode(q);
- }
-
info = get_itbl(q);
switch (info->type) {
diff --git a/rts/sm/GC.c b/rts/sm/GC.c
index a7b8ad3a42..8a8e1573dd 100644
--- a/rts/sm/GC.c
+++ b/rts/sm/GC.c
@@ -273,10 +273,6 @@ GarbageCollect (uint32_t collect_gen,
static_flag == STATIC_FLAG_A ? STATIC_FLAG_B : STATIC_FLAG_A;
}
- if (major_gc) {
- prepareUnloadCheck();
- }
-
#if defined(THREADED_RTS)
work_stealing = RtsFlags.ParFlags.parGcLoadBalancingEnabled &&
N >= RtsFlags.ParFlags.parGcLoadBalancingGen;
@@ -736,9 +732,7 @@ GarbageCollect (uint32_t collect_gen,
// mark the garbage collected CAFs as dead
#if defined(DEBUG)
- if (major_gc) {
- gcCAFs();
- }
+ if (major_gc) { gcCAFs(); }
#endif
// Update the stable name hash table
@@ -749,10 +743,9 @@ GarbageCollect (uint32_t collect_gen,
// hs_free_stable_ptr(), both of which access the StablePtr table.
stablePtrUnlock();
- // Unload dynamically-loaded object code after a major GC.
- // See Note [Object unloading] in CheckUnload.c for details.
+ // Must be after stablePtrUnlock(), because it might free stable ptrs.
if (major_gc) {
- checkUnload();
+ checkUnload (gct->scavenged_static_objects);
}
#if defined(PROFILING)
diff --git a/rts/sm/HeapUtils.h b/rts/sm/HeapUtils.h
deleted file mode 100644
index 877c5ffa13..0000000000
--- a/rts/sm/HeapUtils.h
+++ /dev/null
@@ -1,38 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team 1998-2008
- *
- * General utilities for walking the heap
- *
- * ---------------------------------------------------------------------------*/
-
-#pragma once
-
-typedef void (walk_closures_cb)(StgClosure **, void *);
-
-INLINE_HEADER void
-walk_large_bitmap(walk_closures_cb *cb,
- StgClosure **p,
- StgLargeBitmap *large_bitmap,
- StgWord size,
- void *user)
-{
- // Bitmap may have more bits than `size` when scavenging PAP payloads. See
- // comments around StgPAP.
- ASSERT(large_bitmap->size >= size);
-
- uint32_t b = 0;
-
- for (uint32_t i = 0; i < size; b++) {
- StgWord bitmap = large_bitmap->bitmap[b];
- uint32_t j = stg_min(size-i, BITS_IN(W_));
- i += j;
- for (; j > 0; j--, p++) {
- if ((bitmap & 1) == 0) {
- cb(p, user);
- }
- bitmap = bitmap >> 1;
- }
- }
-}
-
diff --git a/testsuite/tests/ghci/T16525a/T16525a.script b/testsuite/tests/ghci/T16525a/T16525a.script
index 51fcea42a0..d48cfd0f2d 100644
--- a/testsuite/tests/ghci/T16525a/T16525a.script
+++ b/testsuite/tests/ghci/T16525a/T16525a.script
@@ -1,10 +1,6 @@
:set -fobject-code
:load A
import Control.Concurrent
-_ <- forkIO $ threadDelay 500000 >> print (map v1 value)
+_ <- forkIO $ threadDelay 1000000 >> (print (map v1 value))
:l []
System.Mem.performGC
-threadDelay 500000
-System.Mem.performGC
-threadDelay 500000
-System.Mem.performGC
diff --git a/testsuite/tests/ghci/T16525a/T16525a.stdout b/testsuite/tests/ghci/T16525a/T16525a.stdout
index e88107d8e3..e69de29bb2 100644
--- a/testsuite/tests/ghci/T16525a/T16525a.stdout
+++ b/testsuite/tests/ghci/T16525a/T16525a.stdout
@@ -1 +0,0 @@
-["a;lskdfa;lszkfsd;alkfjas"]
diff --git a/testsuite/tests/ghci/T16525a/all.T b/testsuite/tests/ghci/T16525a/all.T
index 28d548440d..6fbd3e8a4f 100644
--- a/testsuite/tests/ghci/T16525a/all.T
+++ b/testsuite/tests/ghci/T16525a/all.T
@@ -1,3 +1,5 @@
test('T16525a',
- [extra_files(['A.hs', 'B.hs'])],
+ [extra_files(['A.hs', 'B.hs', ]),
+ extra_run_opts('+RTS -DS -RTS'),
+ when(ghc_dynamic(), skip), ],
ghci_script, ['T16525a.script'])
diff --git a/testsuite/tests/ghci/T16525b/A.hs b/testsuite/tests/ghci/T16525b/A.hs
deleted file mode 100644
index 9abc8d9b51..0000000000
--- a/testsuite/tests/ghci/T16525b/A.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module A (a) where
-
-import B
-
-a :: () -> IO Int
-a x = b x
diff --git a/testsuite/tests/ghci/T16525b/B.hs b/testsuite/tests/ghci/T16525b/B.hs
deleted file mode 100644
index 72d33b6660..0000000000
--- a/testsuite/tests/ghci/T16525b/B.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module B (b) where
-
-{-# NOINLINE b #-}
-b :: () -> IO Int
-b () = return 999999999
diff --git a/testsuite/tests/ghci/T16525b/T16525b.script b/testsuite/tests/ghci/T16525b/T16525b.script
deleted file mode 100644
index 2917c67df8..0000000000
--- a/testsuite/tests/ghci/T16525b/T16525b.script
+++ /dev/null
@@ -1,22 +0,0 @@
-:set -fobject-code
-:load A
-import Control.Concurrent
-import Control.Monad
-:{
-_ <- forkIO $ do
- replicateM_ 3 (a () >>= print >> threadDelay 500000)
- putStrLn "===== THREAD DONE ====="
-:}
-:l []
-System.Mem.performGC
-threadDelay 500000
-System.Mem.performGC
-threadDelay 500000
-System.Mem.performGC
-threadDelay 500000
-System.Mem.performGC
-threadDelay 500000
-System.Mem.performGC
-threadDelay 500000
-System.Mem.performGC
-threadDelay 500000
diff --git a/testsuite/tests/ghci/T16525b/T16525b.stdout b/testsuite/tests/ghci/T16525b/T16525b.stdout
deleted file mode 100644
index 9b3c71a6ea..0000000000
--- a/testsuite/tests/ghci/T16525b/T16525b.stdout
+++ /dev/null
@@ -1,4 +0,0 @@
-999999999
-999999999
-999999999
-===== THREAD DONE =====
diff --git a/testsuite/tests/ghci/T16525b/all.T b/testsuite/tests/ghci/T16525b/all.T
deleted file mode 100644
index edefb4423b..0000000000
--- a/testsuite/tests/ghci/T16525b/all.T
+++ /dev/null
@@ -1,2 +0,0 @@
-# Tests unloading an object file which is in use in a thread
-test('T16525b', [extra_files(['A.hs', 'B.hs'])], ghci_script, ['T16525b.script'])
diff --git a/testsuite/tests/rts/linker_error.c b/testsuite/tests/rts/linker_error.c
index 632c4b7862..264c95d710 100644
--- a/testsuite/tests/rts/linker_error.c
+++ b/testsuite/tests/rts/linker_error.c
@@ -57,10 +57,7 @@ int main (int argc, char *argv[])
r = resolveObjs();
if (!r) {
debugBelch("resolveObjs failed\n");
- // Mark the object as unloadable:
unloadObj(obj);
- // Actually unload it:
- performMajorGC();
continue;
}
errorBelch("loading succeeded");
diff --git a/testsuite/tests/rts/linker_unload_native.c b/testsuite/tests/rts/linker_unload_native.c
index 29bcf95856..65e8a42259 100644
--- a/testsuite/tests/rts/linker_unload_native.c
+++ b/testsuite/tests/rts/linker_unload_native.c
@@ -6,7 +6,8 @@
#include <dlfcn.h>
// poke into linker internals
-extern void *objects;
+extern void *native_objects;
+extern void *unloaded_native_objects;
#define ITERATIONS 1000
@@ -40,7 +41,6 @@ int main (int argc, char *argv[])
for (i=0; i < ITERATIONS; i++) {
char* errmsg;
- // load 2 libraries at once
void* handle = loadNativeObj(OBJPATH, &errmsg);
if (!handle) {
errorBelch("loadNativeObj(%s) failed: %s", OBJPATH, errmsg);
@@ -48,6 +48,18 @@ int main (int argc, char *argv[])
exit(1);
}
+ // loading the same library again should fail
+ void* handle1 = loadNativeObj(OBJPATH, &errmsg);
+ if (!handle1) {
+ // don't spam the output file:
+ // errorBelch("loadNativeObj(%s) failed: %s", OBJPATH, errmsg);
+ free(errmsg);
+ } else {
+ errorBelch("loadNativeObj(%s) should have failed", OBJPATH);
+ exit(1);
+ }
+
+ // load 2 libraries at once
void* handle2 = loadNativeObj(OBJPATH2, &errmsg);
if (!handle2) {
errorBelch("loadNativeObj(%s) failed: %s", OBJPATH2, errmsg);
@@ -85,9 +97,8 @@ int main (int argc, char *argv[])
printf("%d ", i);
fflush(stdout);
}
-
- // Verify that Test.so isn't still loaded.
- int res = getObjectLoadStatus("Test.so") != OBJECT_NOT_LOADED;
+ // if we unloaded everything, these should be NULL
+ printf("\n%p %p\n", unloaded_native_objects, native_objects);
hs_exit();
- exit(res);
+ exit(0);
}
diff --git a/testsuite/tests/rts/linker_unload_native.stdout b/testsuite/tests/rts/linker_unload_native.stdout
index 534e7554e8..2a96d53edd 100644
--- a/testsuite/tests/rts/linker_unload_native.stdout
+++ b/testsuite/tests/rts/linker_unload_native.stdout
@@ -1,3 +1,4 @@
[1 of 1] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o )
Linking linker_unload_native ...
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999
+(nil) (nil)