diff options
Diffstat (limited to 'rts')
41 files changed, 1529 insertions, 1665 deletions
diff --git a/rts/Adjustor.c b/rts/Adjustor.c index fbf95df936..873f3acad1 100644 --- a/rts/Adjustor.c +++ b/rts/Adjustor.c @@ -131,8 +131,8 @@ createAdjustor (int cconv, barf("createAdjustor: failed to allocate memory"); } - r = ffi_prep_closure(cl, cif, (void*)wptr, hptr/*userdata*/); - if (r != FFI_OK) barf("ffi_prep_closure failed: %d", r); + r = ffi_prep_closure_loc(cl, cif, (void*)wptr, hptr/*userdata*/, code); + if (r != FFI_OK) barf("ffi_prep_closure_loc failed: %d", r); return (void*)code; } @@ -335,7 +335,7 @@ createAdjustor(int cconv, StgStablePtr hptr, ) { void *adjustor = NULL; - void *code; + void *code = NULL; switch (cconv) { @@ -491,22 +491,15 @@ createAdjustor(int cconv, StgStablePtr hptr, */ { - int i = 0; - int fourthFloating; - char *c; StgWord8 *adj_code; // determine whether we have 4 or more integer arguments, // and therefore need to flush one to the stack. - for (c = typeString; *c != '\0'; c++) { - i++; - if (i == 4) { - fourthFloating = (*c == 'f' || *c == 'd'); - break; - } - } + if ((typeString[0] == '\0') || + (typeString[1] == '\0') || + (typeString[2] == '\0') || + (typeString[3] == '\0')) { - if (i < 4) { adjustor = allocateExec(0x38,&code); adj_code = (StgWord8*)adjustor; @@ -525,6 +518,9 @@ createAdjustor(int cconv, StgStablePtr hptr, } else { + int fourthFloating; + + fourthFloating = (typeString[3] == 'f' || typeString[3] == 'd'); adjustor = allocateExec(0x58,&code); adj_code = (StgWord8*)adjustor; *(StgInt32 *)adj_code = 0x08ec8348; diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c new file mode 100644 index 0000000000..a758b06db3 --- /dev/null +++ b/rts/CheckUnload.c @@ -0,0 +1,303 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 2013- + * + * Check whether dynamically-loaded object code can be safely + * unloaded, by searching for references to it from the heap and RTS + * data structures. + * + * --------------------------------------------------------------------------*/ + +#include "PosixSource.h" +#include "Rts.h" + +#include "RtsUtils.h" +#include "Hash.h" +#include "LinkerInternals.h" +#include "CheckUnload.h" +#include "sm/Storage.h" +#include "sm/GCThread.h" + +// +// 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 +// +// 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. +// +// 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. +// + +static void checkAddress (HashTable *addrs, void *addr) +{ + ObjectCode *oc; + + if (!lookupHashTable(addrs, (W_)addr)) { + insertHashTable(addrs, (W_)addr, addr); + + for (oc = unloaded_objects; oc; oc = oc->next) { + if ((W_)addr >= (W_)oc->image && + (W_)addr < (W_)oc->image + oc->fileSize) { + oc->referenced = 1; + break; + } + } + } +} + +static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end) +{ + StgPtr p; + const StgRetInfoTable *info; + + p = sp; + while (p < stack_end) { + info = get_ret_itbl((StgClosure *)p); + + switch (info->i.type) { + case RET_SMALL: + case RET_BIG: + checkAddress(addrs, (void*)info); + break; + + default: + break; + } + + p += stack_frame_sizeW((StgClosure*)p); + } +} + + +static void searchHeapBlocks (HashTable *addrs, bdescr *bd) +{ + StgPtr p; + StgInfoTable *info; + nat size; + rtsBool prim; + + for (; bd != NULL; bd = bd->link) { + + if (bd->flags & BF_PINNED) { + // Assume that objects in PINNED blocks cannot refer to + continue; + } + + p = bd->start; + while (p < bd->free) { + info = get_itbl((StgClosure *)p); + prim = rtsFalse; + + 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 CONSTR: + case FUN: + case FUN_1_0: + case FUN_0_1: + case FUN_1_1: + case FUN_0_2: + case FUN_2_0: + 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 IND_PERM: + case BLACKHOLE: + case BLOCKING_QUEUE: + prim = rtsTrue; + 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 = rtsTrue; + size = BLACKHOLE_sizeW(); + break; + + case BCO: + prim = rtsTrue; + 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 = rtsTrue; + size = sizeW_fromITBL(info); + break; + + case AP: + prim = rtsTrue; + size = ap_sizeW((StgAP *)p); + break; + + case PAP: + prim = rtsTrue; + size = pap_sizeW((StgPAP *)p); + break; + + case AP_STACK: + { + StgAP_STACK *ap = (StgAP_STACK *)p; + prim = rtsTrue; + size = ap_stack_sizeW(ap); + searchStackChunk(addrs, (StgPtr)ap->payload, + (StgPtr)ap->payload + ap->size); + break; + } + + case ARR_WORDS: + prim = rtsTrue; + size = arr_words_sizeW((StgArrWords*)p); + break; + + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + prim = rtsTrue; + size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p); + break; + + case TSO: + prim = rtsTrue; + size = sizeofW(StgTSO); + break; + + case STACK: { + StgStack *stack = (StgStack*)p; + prim = rtsTrue; + searchStackChunk(addrs, stack->sp, + stack->stack + stack->stack_size); + size = stack_sizeW(stack); + break; + } + + case TREC_CHUNK: + prim = rtsTrue; + size = sizeofW(StgTRecChunk); + break; + + default: + barf("heapCensus, unknown object: %d", info->type); + } + + if (!prim) { + checkAddress(addrs,info); + } + + p += size; + } + } +} + +// +// 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) +{ + nat g, n; + HashTable *addrs; + StgClosure* p; + const StgInfoTable *info; + ObjectCode *oc, *prev; + gen_workspace *ws; + StgClosure* link; + + if (unloaded_objects == NULL) return; + + // Mark every unloadable object as unreferenced initially + for (oc = unloaded_objects; oc; oc = oc->next) { + IF_DEBUG(linker, debugBelch("Checking whether to unload %s\n", + oc->fileName)); + oc->referenced = rtsFalse; + } + + addrs = allocHashTable(); + + for (p = static_objects; p != END_OF_STATIC_LIST; p = link) { + checkAddress(addrs, p); + info = get_itbl(p); + link = *STATIC_LINK(info, p); + } + + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + searchHeapBlocks (addrs, generations[g].blocks); + searchHeapBlocks (addrs, generations[g].large_objects); + + 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); + } + } + + // 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. + prev = NULL; + for (oc = unloaded_objects; oc; prev = oc, oc = 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 %s\n", + oc->fileName)); + freeObjectCode(oc); + } else { + IF_DEBUG(linker, debugBelch("Object file still in use: %s\n", + oc->fileName)); + } + } + + freeHashTable(addrs, NULL); +} diff --git a/rts/CheckUnload.h b/rts/CheckUnload.h new file mode 100644 index 0000000000..7d2e5b1321 --- /dev/null +++ b/rts/CheckUnload.h @@ -0,0 +1,20 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 2013- + * + * Check whether dynamically-loaded object code can be safely + * unloaded, by searching for references to it from the heap and RTS + * data structures. + * + * --------------------------------------------------------------------------*/ + +#ifndef CHECKUNLOAD_H +#define CHECKUNLOAD_H + +#include "BeginPrivate.h" + +void checkUnload (StgClosure *static_objects); + +#include "EndPrivate.h" + +#endif // CHECKUNLOAD_H diff --git a/rts/FrontPanel.c b/rts/FrontPanel.c deleted file mode 100644 index b0b9bced4a..0000000000 --- a/rts/FrontPanel.c +++ /dev/null @@ -1,796 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team 2000 - * - * RTS GTK Front Panel - * - * ---------------------------------------------------------------------------*/ - -#ifdef RTS_GTK_FRONTPANEL - -/* Alas, not Posix. */ -/* #include "PosixSource.h" */ - -#include "Rts.h" - -#include "RtsUtils.h" -#include "FrontPanel.h" -#include "Stats.h" -#include "Schedule.h" - -#include <gtk/gtk.h> -#include <unistd.h> -#include <string.h> - -#include "VisSupport.h" -#include "VisWindow.h" - -static GtkWidget *window, *map_drawing_area, *gen_drawing_area; -static GtkWidget *res_drawing_area; -static GtkWidget *continue_but, *stop_but, *quit_but; -static GtkWidget *statusbar; -static GtkWidget *live_label, *allocated_label; -static GtkWidget *footprint_label, *alloc_rate_label; -static GtkWidget *map_ruler, *gen_ruler; -static GtkWidget *res_vruler, *res_hruler; -static GtkWidget *running_label, *b_read_label, *b_write_label, *total_label; -static GtkWidget *b_mvar_label, *b_bh_label, *b_throwto_label, *sleeping_label; - -static guint status_context_id; - -gboolean continue_now = FALSE, stop_now = FALSE, quit = FALSE; -UpdateMode update_mode = Continuous; - -static GdkPixmap *map_pixmap = NULL; -static GdkPixmap *gen_pixmap = NULL; -static GdkPixmap *res_pixmap = NULL; - -#define N_GENS 10 - -static GdkColor - bdescr_color = { 0, 0xffff, 0, 0 }, /* red */ - free_color = { 0, 0, 0, 0xffff }, /* blue */ - gen_colors[N_GENS] = { - { 0, 0, 0xffff, 0 }, - { 0, 0, 0xf000, 0 }, - { 0, 0, 0xe000, 0 }, - { 0, 0, 0xd000, 0 }, - { 0, 0, 0xc000, 0 }, - { 0, 0, 0xb000, 0 }, - { 0, 0, 0xa000, 0 }, - { 0, 0, 0x9000, 0 }, - { 0, 0, 0x8000, 0 }, - { 0, 0, 0x7000, 0 } - }; - -GdkGC *my_gc = NULL; - -static void *mem_start = (void *) 0x50000000; - -static void colorBlock( void *addr, GdkColor *color, - nat block_width, nat block_height, - nat blocks_per_line ); - -static void residencyCensus( void ); -static void updateResidencyGraph( void ); -static void updateThreadsPanel( void ); - -/* Some code pinched from examples/scribble-simple in the GTK+ - * distribution. - */ - -/* Create a new backing pixmap of the appropriate size */ -static gint -configure_event( GtkWidget *widget, GdkEventConfigure *event STG_UNUSED, - GdkPixmap **pixmap ) -{ - if (*pixmap) - gdk_pixmap_unref(*pixmap); - - *pixmap = gdk_pixmap_new(widget->window, - widget->allocation.width, - widget->allocation.height, - -1); - - gdk_draw_rectangle (*pixmap, - widget->style->white_gc, - TRUE, - 0, 0, - widget->allocation.width, - widget->allocation.height); - - debugBelch("configure!\n"); - updateFrontPanel(); - return TRUE; -} - -/* Redraw the screen from the backing pixmap */ -static gint -expose_event( GtkWidget *widget, GdkEventExpose *event, GdkPixmap **pixmap ) -{ - gdk_draw_pixmap(widget->window, - widget->style->fg_gc[GTK_WIDGET_STATE (widget)], - *pixmap, - event->area.x, event->area.y, - event->area.x, event->area.y, - event->area.width, event->area.height); - - return FALSE; -} - -void -initFrontPanel( void ) -{ - GdkColormap *colormap; - GtkWidget *gen_hbox; - - gtk_init( &prog_argc, &prog_argv ); - - window = create_GHC_Front_Panel(); - map_drawing_area = lookup_widget(window, "memmap"); - gen_drawing_area = lookup_widget(window, "generations"); - res_drawing_area = lookup_widget(window, "res_drawingarea"); - stop_but = lookup_widget(window, "stop_but"); - continue_but = lookup_widget(window, "continue_but"); - quit_but = lookup_widget(window, "quit_but"); - statusbar = lookup_widget(window, "statusbar"); - live_label = lookup_widget(window, "live_label"); - footprint_label = lookup_widget(window, "footprint_label"); - allocated_label = lookup_widget(window, "allocated_label"); - alloc_rate_label = lookup_widget(window, "alloc_rate_label"); - gen_hbox = lookup_widget(window, "gen_hbox"); - gen_ruler = lookup_widget(window, "gen_ruler"); - map_ruler = lookup_widget(window, "map_ruler"); - res_vruler = lookup_widget(window, "res_vruler"); - res_hruler = lookup_widget(window, "res_hruler"); - running_label = lookup_widget(window, "running_label"); - b_read_label = lookup_widget(window, "blockread_label"); - b_write_label = lookup_widget(window, "blockwrite_label"); - b_mvar_label = lookup_widget(window, "blockmvar_label"); - b_bh_label = lookup_widget(window, "blockbh_label"); - b_throwto_label = lookup_widget(window, "blockthrowto_label"); - sleeping_label = lookup_widget(window, "sleeping_label"); - total_label = lookup_widget(window, "total_label"); - - status_context_id = - gtk_statusbar_get_context_id( GTK_STATUSBAR(statusbar), "context" ); - - /* hook up some signals for the mem map drawing area */ - gtk_signal_connect (GTK_OBJECT(map_drawing_area), "expose_event", - (GtkSignalFunc)expose_event, &map_pixmap); - gtk_signal_connect (GTK_OBJECT(map_drawing_area), "configure_event", - (GtkSignalFunc)configure_event, &map_pixmap); - - gtk_widget_set_events(map_drawing_area, GDK_EXPOSURE_MASK); - - /* hook up some signals for the gen drawing area */ - gtk_signal_connect (GTK_OBJECT(gen_drawing_area), "expose_event", - (GtkSignalFunc)expose_event, &gen_pixmap); - gtk_signal_connect (GTK_OBJECT(gen_drawing_area), "configure_event", - (GtkSignalFunc)configure_event, &gen_pixmap); - - gtk_widget_set_events(gen_drawing_area, GDK_EXPOSURE_MASK); - - /* hook up some signals for the res drawing area */ - gtk_signal_connect (GTK_OBJECT(res_drawing_area), "expose_event", - (GtkSignalFunc)expose_event, &res_pixmap); - gtk_signal_connect (GTK_OBJECT(res_drawing_area), "configure_event", - (GtkSignalFunc)configure_event, &res_pixmap); - - gtk_widget_set_events(res_drawing_area, GDK_EXPOSURE_MASK); - - /* allocate our colors */ - colormap = gdk_colormap_get_system(); - gdk_colormap_alloc_color(colormap, &bdescr_color, TRUE, TRUE); - gdk_colormap_alloc_color(colormap, &free_color, TRUE, TRUE); - - { - gboolean success[N_GENS]; - gdk_colormap_alloc_colors(colormap, gen_colors, N_GENS, TRUE, - TRUE, success); - if (!success) { barf("can't allocate colors"); } - } - - /* set the labels on the generation histogram */ - { - char buf[64]; - nat g, s; - GtkWidget *label; - - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - for(s = 0; s < generations[g].n_steps; s++) { - g_snprintf( buf, 64, "%d.%d", g, s ); - label = gtk_label_new( buf ); - gtk_box_pack_start( GTK_BOX(gen_hbox), label, - TRUE, TRUE, 5 ); - gtk_widget_show(label); - } - } - } - - gtk_widget_show(window); - - /* wait for the user to press "Continue" before getting going... */ - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, - "Program start"); - gtk_widget_set_sensitive( stop_but, FALSE ); - continue_now = FALSE; - while (continue_now == FALSE) { - gtk_main_iteration(); - } - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, - "Running"); - - gtk_widget_set_sensitive( continue_but, FALSE ); - gtk_widget_set_sensitive( stop_but, TRUE ); - gtk_widget_set_sensitive( quit_but, FALSE ); - - while (gtk_events_pending()) { - gtk_main_iteration(); - } -} - -void -stopFrontPanel( void ) -{ - gtk_widget_set_sensitive( quit_but, TRUE ); - gtk_widget_set_sensitive( continue_but, FALSE ); - gtk_widget_set_sensitive( stop_but, FALSE ); - - updateFrontPanel(); - - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, - "Program finished"); - - quit = FALSE; - while (quit == FALSE) { - gtk_main_iteration(); - } -} - -static void -waitForContinue( void ) -{ - gtk_widget_set_sensitive( continue_but, TRUE ); - gtk_widget_set_sensitive( stop_but, FALSE ); - stop_now = FALSE; - continue_now = FALSE; - while (continue_now == FALSE) { - gtk_main_iteration(); - } - gtk_widget_set_sensitive( continue_but, FALSE ); - gtk_widget_set_sensitive( stop_but, TRUE ); -} - -void -updateFrontPanelBeforeGC( nat N ) -{ - char buf[1000]; - - updateFrontPanel(); - - if (update_mode == BeforeGC - || update_mode == BeforeAfterGC - || stop_now == TRUE) { - g_snprintf( buf, 1000, "Stopped (before GC, generation %d)", N ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, buf ); - waitForContinue(); - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - } - - g_snprintf( buf, 1000, "Garbage collecting (generation %d)", N ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, buf); - - while (gtk_events_pending()) { - gtk_main_iteration(); - } -} - -static void -numLabel( GtkWidget *lbl, nat n ) -{ - char buf[64]; - g_snprintf(buf, 64, "%d", n); - gtk_label_set_text( GTK_LABEL(lbl), buf ); -} - -void -updateFrontPanelAfterGC( nat N, W_ live ) -{ - char buf[1000]; - - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - - /* is a major GC? */ - if (N == RtsFlags.GcFlags.generations-1) { - residencyCensus(); - } - - updateFrontPanel(); - - if (update_mode == AfterGC - || update_mode == BeforeAfterGC - || stop_now == TRUE) { - snprintf( buf, 1000, "Stopped (after GC, generation %d)", N ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, buf ); - waitForContinue(); - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - } - - { - double words_to_megs = (1024 * 1024) / sizeof(W_); - double time = mut_user_time(); - - snprintf( buf, 1000, "%.2f", (double)live / words_to_megs ); - gtk_label_set_text( GTK_LABEL(live_label), buf ); - - snprintf( buf, 1000, "%.2f", (double)total_allocated / words_to_megs ); - gtk_label_set_text( GTK_LABEL(allocated_label), buf ); - - snprintf( buf, 1000, "%.2f", - (double)(mblocks_allocated * MBLOCK_SIZE_W) / words_to_megs ); - gtk_label_set_text( GTK_LABEL(footprint_label), buf ); - - if ( time == 0.0 ) - snprintf( buf, 1000, "%.2f", time ); - else - snprintf( buf, 1000, "%.2f", - (double)(total_allocated / words_to_megs) / time ); - gtk_label_set_text( GTK_LABEL(alloc_rate_label), buf ); - } - - while (gtk_events_pending()) { - gtk_main_iteration(); - } -} - -void -updateFrontPanel( void ) -{ - void *m, *a; - bdescr *bd; - - updateThreadsPanel(); - - if (my_gc == NULL) { - my_gc = gdk_gc_new( window->window ); - } - - if (map_pixmap != NULL) { - nat height, width, blocks_per_line, - block_height, block_width, mblock_height; - - height = map_drawing_area->allocation.height; - width = map_drawing_area->allocation.width; - - mblock_height = height / mblocks_allocated; - blocks_per_line = 16; - block_height = mblock_height / - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - while (block_height == 0) { - blocks_per_line *= 2; - block_height = mblock_height / - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - } - block_width = width / blocks_per_line; - - gdk_draw_rectangle (map_pixmap, - map_drawing_area->style->bg_gc[GTK_STATE_NORMAL], - TRUE, - 0, 0, - map_drawing_area->allocation.width, - map_drawing_area->allocation.height); - - for ( m = mem_start; - (char *)m < (char *)mem_start + - (mblocks_allocated * MBLOCK_SIZE); - (char *)m += MBLOCK_SIZE ) { - - /* color the bdescr area first */ - for (a = m; a < FIRST_BLOCK(m); (char *)a += BLOCK_SIZE) { - colorBlock( a, &bdescr_color, - block_width, block_height, blocks_per_line ); - } - -#if 0 /* Segfaults because bd appears to be bogus but != NULL. stolz, 2003-06-24 */ - /* color each block */ - for (; a <= LAST_BLOCK(m); (char *)a += BLOCK_SIZE) { - bd = Bdescr((P_)a); - ASSERT(bd->start == a); - if (bd->flags & BF_FREE) { - colorBlock( a, &free_color, - block_width, block_height, blocks_per_line ); - } else { - colorBlock( a, &gen_colors[bd->gen_no], - block_width, block_height, blocks_per_line ); - } - } -#endif - } - - - { - nat height = map_drawing_area->allocation.height, - block_height, mblock_height; - - block_height = (height / mblocks_allocated) / - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - if (block_height < 1) block_height = 1; - mblock_height = block_height * - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - - gtk_ruler_set_range( GTK_RULER(map_ruler), 0, - (double)(height * mblocks_allocated) / - (double)((mblock_height * mblocks_allocated)), - 0, - (double)(height * mblocks_allocated) / - (double)((mblock_height * mblocks_allocated)) - ); - } - - gtk_widget_draw( map_drawing_area, NULL ); - } - - if (gen_pixmap != NULL) { - - GdkRectangle rect; - nat g, s, columns, column, max_blocks, height_blocks, - width, height; - - gdk_draw_rectangle (gen_pixmap, - gen_drawing_area->style->white_gc, - TRUE, - 0, 0, - gen_drawing_area->allocation.width, - gen_drawing_area->allocation.height); - - height = gen_drawing_area->allocation.height; - width = gen_drawing_area->allocation.width; - - columns = 0; max_blocks = 0; - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - columns += generations[g].n_steps; - for(s = 0; s < generations[g].n_steps; s++) { - if (generations[g].steps[s].n_blocks > max_blocks) { - max_blocks = generations[g].steps[s].n_blocks; - } - } - } - - /* find a reasonable height value larger than max_blocks */ - { - nat n = 0; - while (max_blocks != 0) { - max_blocks >>= 1; n++; - } - height_blocks = 1 << n; - } - - column = 0; - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - for(s = 0; s < generations[g].n_steps; s++, column++) { - gdk_gc_set_foreground(my_gc, &gen_colors[g]); - - rect.x = column * (width / columns); - - if (generations[g].steps[s].n_blocks == 0) - rect.y = height; - else - rect.y = height - - (height * generations[g].steps[s].n_blocks - / height_blocks); - - rect.width = (width / columns); - rect.height = height - rect.y; - - gdk_draw_rectangle( gen_pixmap, my_gc, TRUE/*filled*/, - rect.x, rect.y, rect.width, - rect.height ); - } - } - - gtk_ruler_set_range( GTK_RULER(gen_ruler), - height_blocks * BLOCK_SIZE / (1024 * 1024), - 0, 0, - height_blocks * BLOCK_SIZE / (1024 * 1024) - ); - - gtk_widget_draw( gen_drawing_area, NULL ); - } - - if (res_pixmap != NULL) { - updateResidencyGraph(); - } - - while (gtk_events_pending()) { - gtk_main_iteration_do(FALSE/*don't block*/); - } -} - -static void -colorBlock( void *addr, GdkColor *color, - nat block_width, nat block_height, nat blocks_per_line ) -{ - GdkRectangle rect; - nat block_no; - - gdk_gc_set_foreground(my_gc, color); - - block_no = ((char *)addr - (char *)mem_start) / BLOCK_SIZE; - - rect.x = (block_no % blocks_per_line) * block_width; - rect.y = block_no / blocks_per_line * block_height; - rect.width = block_width; - rect.height = block_height; - gdk_draw_rectangle( map_pixmap, my_gc, TRUE/*filled*/, - rect.x, rect.y, rect.width, rect.height ); -} - -static void -updateThreadsPanel( void ) -{ - nat running = 0, - b_read = 0, - b_write = 0, - b_mvar = 0, - b_throwto = 0, - b_bh = 0, - sleeping = 0, - total = 0; - - StgTSO *t; - - for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) { - switch (t->what_next) { - case ThreadKilled: break; - case ThreadComplete: break; - default: - switch (t->why_blocked) { - case BlockedOnRead: b_read++; break; - case BlockedOnWrite: b_write++; break; - case BlockedOnDelay: sleeping++; break; - case BlockedOnMVar: b_mvar++; break; - case BlockedOnException: b_throwto++; break; - case BlockedOnBlackHole: b_bh++; break; - case NotBlocked: running++; break; - } - } - } - total = running + b_read + b_write + b_mvar + b_throwto + b_bh + sleeping; - numLabel(running_label, running); - numLabel(b_read_label, b_read); - numLabel(b_write_label, b_write); - numLabel(b_mvar_label, b_mvar); - numLabel(b_bh_label, b_bh); - numLabel(b_throwto_label, b_throwto); - numLabel(sleeping_label, sleeping); - numLabel(total_label, total); -} - -typedef enum { Thunk, Fun, Constr, BlackHole, - Array, Thread, Other, N_Cats } ClosureCategory; - -#define N_SLICES 100 - -static nat *res_prof[N_SLICES]; -static double res_time[N_SLICES]; -static nat next_slice = 0; - -static void -residencyCensus( void ) -{ - nat slice = next_slice++, *prof; - bdescr *bd; - nat g, s, size, type; - StgPtr p; - StgInfoTable *info; - - if (slice >= N_SLICES) { - barf("too many slices"); - } - res_prof[slice] = stgMallocBytes(N_Cats * sizeof(nat), "residencyCensus"); - prof = res_prof[slice]; - memset(prof, 0, N_Cats * sizeof(nat)); - - res_time[slice] = mut_user_time(); - - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - for(s = 0; s < generations[g].n_steps; s++) { - - /* skip over g0s0 if multi-generational */ - if (RtsFlags.GcFlags.generations > 1 && - g == 0 && s == 0) continue; - - if (RtsFlags.GcFlags.generations == 1) { -/* bd = generations[g].steps[s].to_blocks; FIXME to_blocks does not exist */ - } else { - bd = generations[g].steps[s].blocks; - } - - for (; bd != NULL; bd = bd->link) { - - p = bd->start; - - while (p < bd->free) { - info = get_itbl((StgClosure *)p); - type = Other; - - switch (info->type) { - - case CONSTR: - case BCO: - if (((StgClosure *)p)->header.info == &stg_DEAD_WEAK_info) { - size = sizeofW(StgWeak); - type = Other; - break; - } - /* else, fall through... */ - case CONSTR_1_0: - case CONSTR_0_1: - case CONSTR_1_1: - case CONSTR_0_2: - case CONSTR_2_0: - size = sizeW_fromITBL(info); - type = Constr; - break; - - case FUN_1_0: - case FUN_0_1: - size = sizeofW(StgHeader) + 1; - goto fun; - case FUN_1_1: - case FUN_0_2: - case FUN_2_0: - case FUN: - size = sizeW_fromITBL(info); - fun: - type = Fun; - break; - - case THUNK_1_0: - case THUNK_0_1: - case THUNK_SELECTOR: - size = sizeofW(StgHeader) + 2; - goto thunk; - case THUNK_1_1: - case THUNK_0_2: - case THUNK_2_0: - case THUNK: - size = sizeW_fromITBL(info); - thunk: - type = Thunk; - break; - - case BLACKHOLE: -/* case BLACKHOLE_BQ: FIXME: case does not exist */ - size = sizeW_fromITBL(info); - type = BlackHole; - break; - - case AP: - size = pap_sizeW((StgPAP *)p); - type = Thunk; - break; - - case PAP: - size = pap_sizeW((StgPAP *)p); - type = Fun; - break; - - case ARR_WORDS: - size = arr_words_sizeW(stgCast(StgArrWords*,p)); - type = Array; - break; - - case MUT_ARR_PTRS: - case MUT_ARR_PTRS_FROZEN: - size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p); - type = Array; - break; - - case TSO: - size = tso_sizeW((StgTSO *)p); - type = Thread; - break; - - case WEAK: - case PRIM: - case MVAR: - case MUT_VAR: -/* case MUT_CONS: FIXME: case does not exist */ - case IND_PERM: - size = sizeW_fromITBL(info); - type = Other; - break; - - default: - barf("updateResidencyGraph: strange closure " - "%d", info->type ); - } - - prof[type] += size; - p += size; - } - } - } - } - -} - -static void -updateResidencyGraph( void ) -{ - nat total, prev_total, i, max_res; - double time; - double time_scale = 1; - nat last_slice = next_slice-1; - double res_scale = 1; /* in megabytes, doubles */ - nat *prof; - nat width, height; - GdkPoint points[4]; - - gdk_draw_rectangle (res_pixmap, - res_drawing_area->style->bg_gc[GTK_STATE_NORMAL], - TRUE, - 0, 0, - res_drawing_area->allocation.width, - res_drawing_area->allocation.height); - - if (next_slice == 0) return; - - time = res_time[last_slice]; - while (time > time_scale) { - time_scale *= 2; - } - - max_res = 0; - for (i = 0; i < next_slice; i++) { - prof = res_prof[i]; - total = prof[Thunk] + prof[Fun] + prof[Constr] + - prof[BlackHole] + prof[Array] + prof[Other]; - if (total > max_res) { - max_res = total; - } - } - while (max_res > res_scale) { - res_scale *= 2; - } - - height = res_drawing_area->allocation.height; - width = res_drawing_area->allocation.width; - - points[0].x = 0; - points[0].y = height; - points[1].y = height; - points[3].x = 0; - points[3].y = height; - - gdk_gc_set_foreground(my_gc, &free_color); - - prev_total = 0; - for (i = 0; i < next_slice; i++) { - prof = res_prof[i]; - total = prof[Thunk] + prof[Fun] + prof[Constr] + - prof[BlackHole] + prof[Array] + prof[Other]; - points[1].x = width * res_time[i] / time_scale; - points[2].x = points[1].x; - points[2].y = height - ((height * total) / res_scale); - gdk_draw_polygon(res_pixmap, my_gc, TRUE/*filled*/, points, 4); - points[3] = points[2]; - points[0] = points[1]; - } - - gtk_ruler_set_range( GTK_RULER(res_vruler), - res_scale / ((1024*1024)/sizeof(W_)), - 0, 0, - res_scale / ((1024*1024)/sizeof(W_)) ); - - gtk_ruler_set_range( GTK_RULER(res_hruler), - 0, time_scale, 0, time_scale ); - - - gtk_widget_draw( res_drawing_area, NULL ); -} - -#endif /* RTS_GTK_FRONTPANEL */ diff --git a/rts/FrontPanel.h b/rts/FrontPanel.h deleted file mode 100644 index 84e40d5e1b..0000000000 --- a/rts/FrontPanel.h +++ /dev/null @@ -1,39 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team 2000-2005 - * - * RTS GTK Front Panel - * - * ---------------------------------------------------------------------------*/ - -#ifndef FRONTPANEL_H -#define FRONTPANEL_H - -#include "BeginPrivate.h" - -#ifdef RTS_GTK_FRONTPANEL - -#include "Rts.h" /* needed because this file gets included by - * auto-generated code */ - -void initFrontPanel( void ); -void stopFrontPanel( void ); -void updateFrontPanelBeforeGC( nat N ); -void updateFrontPanelAfterGC( nat N, W_ live ); -void updateFrontPanel( void ); - - -/* --------- PRIVATE ----------------------------------------- */ - -#include <gdk/gdktypes.h> - -typedef enum { BeforeGC, AfterGC, BeforeAfterGC, Continuous } UpdateMode; -extern UpdateMode update_mode; -extern gboolean continue_now, stop_now, quit; - -#endif /* RTS_GTK_FRONTPANEL */ - -#include "EndPrivate.h" - -#endif /* FRONTPANEL_H */ - diff --git a/rts/Globals.c b/rts/Globals.c index 1aafe21879..2e4b99474f 100644 --- a/rts/Globals.c +++ b/rts/Globals.c @@ -7,8 +7,13 @@ * even when multiple versions of the library are loaded. e.g. see * Data.Typeable and GHC.Conc. * - * If/when we switch to a dynamically-linked GHCi, this can all go - * away, because there would be just one copy of each library. + * How are multiple versions of a library loaded? Examples: + * + * base - a statically-linked ghci has its own copy, so might libraries it + * dynamically loads + * + * libHSghc - a statically-linked ghc has its own copy and so will Core + * plugins it dynamically loads (cf CoreMonad.reinitializeGlobals) * * ---------------------------------------------------------------------------*/ @@ -27,6 +32,7 @@ typedef enum { SystemEventThreadIOManagerThreadStore, SystemTimerThreadEventManagerStore, SystemTimerThreadIOManagerThreadStore, + LibHSghcFastStringTable, MaxStoreKey } StoreKey; @@ -128,3 +134,9 @@ getOrSetSystemTimerThreadIOManagerThreadStore(StgStablePtr ptr) { return getOrSetKey(SystemTimerThreadIOManagerThreadStore,ptr); } + +StgStablePtr +getOrSetLibHSghcFastStringTable(StgStablePtr ptr) +{ + return getOrSetKey(LibHSghcFastStringTable,ptr); +} diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index fbceb7691a..e130cb3660 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -487,11 +487,11 @@ stg_block_noregs /* ----------------------------------------------------------------------------- * takeMVar/putMVar-specific blocks * - * Stack layout for a thread blocked in takeMVar: + * Stack layout for a thread blocked in takeMVar/readMVar: * * ret. addr * ptr to MVar (R1) - * stg_block_takemvar_info + * stg_block_takemvar_info (or stg_block_readmvar_info) * * Stack layout for a thread blocked in putMVar: * @@ -531,6 +531,33 @@ stg_block_takemvar /* mvar passed in R1 */ BLOCK_BUT_FIRST(stg_block_takemvar_finally); } +INFO_TABLE_RET ( stg_block_readmvar, RET_SMALL, W_ info_ptr, P_ mvar ) + return () +{ + jump stg_readMVarzh(mvar); +} + +// code fragment executed just before we return to the scheduler +stg_block_readmvar_finally +{ + W_ r1, r3; + r1 = R1; + r3 = R3; + unlockClosure(R3, stg_MVAR_DIRTY_info); + R1 = r1; + R3 = r3; + jump StgReturn [R1]; +} + +stg_block_readmvar /* mvar passed in R1 */ +{ + Sp_adj(-2); + Sp(1) = R1; + Sp(0) = stg_block_readmvar_info; + R3 = R1; // mvar communicated to stg_block_readmvar_finally in R3 + BLOCK_BUT_FIRST(stg_block_readmvar_finally); +} + INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr, P_ mvar, P_ val ) return () diff --git a/rts/Linker.c b/rts/Linker.c index 585d1e8451..81a267db1b 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -156,6 +156,10 @@ static /*Str*/HashTable *stablehash; /* 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 */ + static HsInt loadOc( ObjectCode* oc ); static ObjectCode* mkOc( pathchar *path, char *image, int imageSize, char *archiveMemberName @@ -229,6 +233,8 @@ static void machoInitSymbolsWithoutUnderscore( void ); #endif #endif +static void freeProddableBlocks (ObjectCode *oc); + /* on x86_64 we have a problem with relocating symbol references in * code that was compiled without -fPIC. By default, the small memory * model is used, which assumes that symbol references can fit in a @@ -321,7 +327,7 @@ typedef struct _RtsSymbolVal { #define Maybe_Stable_Names SymI_HasProto(stg_mkWeakzh) \ SymI_HasProto(stg_mkWeakNoFinalizzerzh) \ - SymI_HasProto(stg_mkWeakForeignEnvzh) \ + SymI_HasProto(stg_addCFinalizzerToWeakzh) \ SymI_HasProto(stg_makeStableNamezh) \ SymI_HasProto(stg_finalizzeWeakzh) @@ -901,8 +907,10 @@ typedef struct _RtsSymbolVal { SymI_NeedsProto(top_ct) \ \ SymI_HasProto(ENT_VIA_NODE_ctr) \ - SymI_HasProto(ENT_STATIC_THK_ctr) \ - SymI_HasProto(ENT_DYN_THK_ctr) \ + SymI_HasProto(ENT_STATIC_THK_SINGLE_ctr) \ + SymI_HasProto(ENT_STATIC_THK_MANY_ctr) \ + SymI_HasProto(ENT_DYN_THK_SINGLE_ctr) \ + SymI_HasProto(ENT_DYN_THK_MANY_ctr) \ SymI_HasProto(ENT_STATIC_FUN_DIRECT_ctr) \ SymI_HasProto(ENT_DYN_FUN_DIRECT_ctr) \ SymI_HasProto(ENT_STATIC_CON_ctr) \ @@ -970,8 +978,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(UPD_NEW_PERM_IND_ctr) \ SymI_HasProto(UPD_OLD_IND_ctr) \ SymI_HasProto(UPD_OLD_PERM_IND_ctr) \ - SymI_HasProto(UPD_BH_UPDATABLE_ctr) \ - SymI_HasProto(UPD_BH_SINGLE_ENTRY_ctr) \ SymI_HasProto(UPD_CAF_BH_UPDATABLE_ctr) \ SymI_HasProto(UPD_CAF_BH_SINGLE_ENTRY_ctr) \ SymI_HasProto(GC_SEL_ABANDONED_ctr) \ @@ -1058,6 +1064,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_yield_to_interpreter) \ SymI_HasProto(stg_block_noregs) \ SymI_HasProto(stg_block_takemvar) \ + SymI_HasProto(stg_block_readmvar) \ SymI_HasProto(stg_block_putmvar) \ MAIN_CAP_SYM \ SymI_HasProto(MallocFailHook) \ @@ -1067,7 +1074,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(addDLL) \ SymI_HasProto(__int_encodeDouble) \ SymI_HasProto(__word_encodeDouble) \ - SymI_HasProto(__2Int_encodeDouble) \ SymI_HasProto(__int_encodeFloat) \ SymI_HasProto(__word_encodeFloat) \ SymI_HasProto(stg_atomicallyzh) \ @@ -1106,9 +1112,9 @@ typedef struct _RtsSymbolVal { SymI_HasProto(getOrSetSystemEventThreadIOManagerThreadStore) \ SymI_HasProto(getOrSetSystemTimerThreadEventManagerStore) \ SymI_HasProto(getOrSetSystemTimerThreadIOManagerThreadStore) \ + SymI_HasProto(getOrSetLibHSghcFastStringTable) \ SymI_HasProto(getGCStats) \ SymI_HasProto(getGCStatsEnabled) \ - SymI_HasProto(genSymZh) \ SymI_HasProto(genericRaise) \ SymI_HasProto(getProgArgv) \ SymI_HasProto(getFullProgArgv) \ @@ -1281,12 +1287,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_ap_7_upd_info) \ SymI_HasProto(stg_exit) \ SymI_HasProto(stg_sel_0_upd_info) \ - SymI_HasProto(stg_sel_10_upd_info) \ - SymI_HasProto(stg_sel_11_upd_info) \ - SymI_HasProto(stg_sel_12_upd_info) \ - SymI_HasProto(stg_sel_13_upd_info) \ - SymI_HasProto(stg_sel_14_upd_info) \ - SymI_HasProto(stg_sel_15_upd_info) \ SymI_HasProto(stg_sel_1_upd_info) \ SymI_HasProto(stg_sel_2_upd_info) \ SymI_HasProto(stg_sel_3_upd_info) \ @@ -1296,13 +1296,37 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_sel_7_upd_info) \ SymI_HasProto(stg_sel_8_upd_info) \ SymI_HasProto(stg_sel_9_upd_info) \ + SymI_HasProto(stg_sel_10_upd_info) \ + SymI_HasProto(stg_sel_11_upd_info) \ + SymI_HasProto(stg_sel_12_upd_info) \ + SymI_HasProto(stg_sel_13_upd_info) \ + SymI_HasProto(stg_sel_14_upd_info) \ + SymI_HasProto(stg_sel_15_upd_info) \ + SymI_HasProto(stg_sel_0_noupd_info) \ + SymI_HasProto(stg_sel_1_noupd_info) \ + SymI_HasProto(stg_sel_2_noupd_info) \ + SymI_HasProto(stg_sel_3_noupd_info) \ + SymI_HasProto(stg_sel_4_noupd_info) \ + SymI_HasProto(stg_sel_5_noupd_info) \ + SymI_HasProto(stg_sel_6_noupd_info) \ + SymI_HasProto(stg_sel_7_noupd_info) \ + SymI_HasProto(stg_sel_8_noupd_info) \ + SymI_HasProto(stg_sel_9_noupd_info) \ + SymI_HasProto(stg_sel_10_noupd_info) \ + SymI_HasProto(stg_sel_11_noupd_info) \ + SymI_HasProto(stg_sel_12_noupd_info) \ + SymI_HasProto(stg_sel_13_noupd_info) \ + SymI_HasProto(stg_sel_14_noupd_info) \ + SymI_HasProto(stg_sel_15_noupd_info) \ SymI_HasProto(stg_upd_frame_info) \ SymI_HasProto(stg_bh_upd_frame_info) \ SymI_HasProto(suspendThread) \ SymI_HasProto(stg_takeMVarzh) \ + SymI_HasProto(stg_readMVarzh) \ SymI_HasProto(stg_threadStatuszh) \ SymI_HasProto(stg_tryPutMVarzh) \ SymI_HasProto(stg_tryTakeMVarzh) \ + SymI_HasProto(stg_tryReadMVarzh) \ SymI_HasProto(stg_unmaskAsyncExceptionszh) \ SymI_HasProto(unloadObj) \ SymI_HasProto(stg_unsafeThawArrayzh) \ @@ -1500,6 +1524,9 @@ initLinker( void ) linker_init_done = 1; } + objects = NULL; + unloaded_objects = NULL; + #if defined(THREADED_RTS) && (defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)) initMutex(&dl_mutex); #endif @@ -2026,6 +2053,40 @@ mmap_again: } #endif // USE_MMAP + +void freeObjectCode (ObjectCode *oc) +{ + int pagesize, size, r; + +#ifdef USE_MMAP + + pagesize = getpagesize(); + size = ROUND_UP(oc->fileSize, pagesize); + + r = munmap(oc->image, size); + if (r == -1) { + sysErrorBelch("munmap"); + } + + if (!USE_CONTIGUOUS_MMAP) + { + munmap(oc->symbol_extras, + ROUND_UP(sizeof(SymbolExtra) * oc->n_symbol_extras, pagesize)); + } + +#else + + stgFree(oc->image); + stgFree(oc->symbol_extras); + +#endif + + stgFree(oc->fileName); + stgFree(oc->archiveMemberName); + stgFree(oc); +} + + static ObjectCode* mkOc( pathchar *path, char *image, int imageSize, char *archiveMemberName @@ -2728,7 +2789,7 @@ resolveObjs( void ) HsInt unloadObj( pathchar *path ) { - ObjectCode *oc, *prev; + ObjectCode *oc, *prev, *next; HsBool unloadedAnyObj = HS_BOOL_FALSE; ASSERT(symhash != NULL); @@ -2736,8 +2797,12 @@ unloadObj( pathchar *path ) initLinker(); + IF_DEBUG(linker, debugBelch("unloadObj: %s\n", path)); + prev = NULL; - for (oc = objects; oc; prev = oc, oc = oc->next) { + for (oc = objects; oc; prev = oc, oc = next) { + next = oc->next; + if (!pathcmp(oc->fileName,path)) { /* Remove all the mappings for the symbols within this @@ -2757,22 +2822,27 @@ unloadObj( pathchar *path ) } else { prev->next = oc->next; } + oc->next = unloaded_objects; + unloaded_objects = oc; - // We're going to leave this in place, in case there are - // any pointers from the heap into it: - // #ifdef mingw32_HOST_OS - // If uncommenting, note that currently oc->image is - // not the right address to free on Win64, as we added - // 4 bytes of padding at the start - // VirtualFree(oc->image); - // #else - // stgFree(oc->image); - // #endif - stgFree(oc->fileName); - stgFree(oc->archiveMemberName); + // The data itself and a few other bits (oc->fileName, + // oc->archiveMemberName) are kept until freeObjectCode(), + // which is only called when it has been determined that + // it is safe to unload the object. stgFree(oc->symbols); - stgFree(oc->sections); - stgFree(oc); + + { + Section *s, *nexts; + + for (s = oc->sections; s != NULL; s = nexts) { + nexts = s->next; + stgFree(s); + } + } + + freeProddableBlocks(oc); + + oc->status = OBJECT_UNLOADED; /* This could be a member of an archive so continue * unloading other members. */ @@ -2822,6 +2892,17 @@ checkProddableBlock (ObjectCode *oc, void *addr, size_t size ) barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr); } +static void freeProddableBlocks (ObjectCode *oc) +{ + ProddableBlock *pb, *next; + + for (pb = oc->proddables; pb != NULL; pb = next) { + next = pb->next; + stgFree(pb); + } + oc->proddables = NULL; +} + /* ----------------------------------------------------------------------------- * Section management. */ @@ -2910,6 +2991,7 @@ static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first ) memcpy(new, oc->image, oc->fileSize); munmap(oc->image, n); oc->image = new; + oc->fileSize = n + (sizeof(SymbolExtra) * count); oc->symbol_extras = (SymbolExtra *) (oc->image + n); } else @@ -4941,6 +5023,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, // Generate veneer SymbolExtra *extra = makeArmSymbolExtra(oc, ELF_R_SYM(info), S+imm+4, 1, is_target_thm); offset = (StgWord32) &extra->jumpIsland - P - 4; + sign = offset >> 31; to_thm = 1; } else if (!is_target_thm && ELF_R_TYPE(info) == R_ARM_THM_CALL) { offset &= ~0x3; diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h index 864e0d1f2f..753279d547 100644 --- a/rts/LinkerInternals.h +++ b/rts/LinkerInternals.h @@ -9,7 +9,11 @@ #ifndef LINKERINTERNALS_H #define LINKERINTERNALS_H -typedef enum { OBJECT_LOADED, OBJECT_RESOLVED } OStatus; +typedef enum { + OBJECT_LOADED, + OBJECT_RESOLVED, + OBJECT_UNLOADED +} OStatus; /* Indication of section kinds for loaded objects. Needed by the GC for deciding whether or not a pointer on the stack @@ -82,6 +86,9 @@ typedef struct _ObjectCode { /* ptr to malloc'd lump of memory holding the obj file */ char* image; + /* flag used when deciding whether to unload an object file */ + int referenced; + #ifdef darwin_HOST_OS /* record by how much image has been deliberately misaligned after allocation, so that we can use realloc */ @@ -121,7 +128,10 @@ typedef struct _ObjectCode { ) extern ObjectCode *objects; +extern ObjectCode *unloaded_objects; void exitLinker( void ); +void freeObjectCode (ObjectCode *oc); + #endif /* LINKERINTERNALS_H */ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index f4e80e9c35..ced15eec99 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -160,16 +160,16 @@ stg_newArrayzh ( W_ n /* words */, gcptr init ) p = arr + SIZEOF_StgMutArrPtrs; for: if (p < arr + WDS(words)) { - W_[p] = init; - p = p + WDS(1); - goto for; + W_[p] = init; + p = p + WDS(1); + goto for; } // Initialise the mark bits with 0 for2: if (p < arr + WDS(size)) { - W_[p] = 0; - p = p + WDS(1); - goto for2; + W_[p] = 0; + p = p + WDS(1); + goto for2; } return (arr); @@ -179,11 +179,11 @@ stg_unsafeThawArrayzh ( gcptr arr ) { // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST // - // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN + // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN // normally doesn't. However, when we freeze a MUT_ARR_PTRS, we leave // it on the mutable list for the GC to remove (removing something from // the mutable list is not easy). - // + // // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list, // when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0 // to indicate that it is still on the mutable list. @@ -198,11 +198,11 @@ stg_unsafeThawArrayzh ( gcptr arr ) if (StgHeader_info(arr) != stg_MUT_ARR_PTRS_FROZEN0_info) { SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info); recordMutable(arr); - // must be done after SET_INFO, because it ASSERTs closure_MUTABLE() - return (arr); + // must be done after SET_INFO, because it ASSERTs closure_MUTABLE() + return (arr); } else { - SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info); - return (arr); + SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info); + return (arr); } } @@ -229,16 +229,16 @@ stg_newArrayArrayzh ( W_ n /* words */ ) p = arr + SIZEOF_StgMutArrPtrs; for: if (p < arr + WDS(words)) { - W_[p] = arr; - p = p + WDS(1); - goto for; + W_[p] = arr; + p = p + WDS(1); + goto for; } // Initialise the mark bits with 0 for2: if (p < arr + WDS(size)) { - W_[p] = 0; - p = p + WDS(1); - goto for2; + W_[p] = 0; + p = p + WDS(1); + goto for2; } return (arr); @@ -258,7 +258,7 @@ stg_newMutVarzh ( gcptr init ) mv = Hp - SIZEOF_StgMutVar + WDS(1); SET_HDR(mv,stg_MUT_VAR_DIRTY_info,CCCS); StgMutVar_var(mv) = init; - + return (mv); } @@ -283,19 +283,19 @@ stg_atomicModifyMutVarzh ( gcptr mv, gcptr f ) { W_ z, x, y, r, h; - /* If x is the current contents of the MutVar#, then + /* If x is the current contents of the MutVar#, then We want to make the new contents point to (sel_0 (f x)) - + and the return value is - - (sel_1 (f x)) + + (sel_1 (f x)) obviously we can share (f x). z = [stg_ap_2 f x] (max (HS + 2) MIN_UPD_SIZE) - y = [stg_sel_0 z] (max (HS + 1) MIN_UPD_SIZE) + y = [stg_sel_0 z] (max (HS + 1) MIN_UPD_SIZE) r = [stg_sel_1 z] (max (HS + 1) MIN_UPD_SIZE) */ @@ -374,18 +374,14 @@ stg_mkWeakzh ( gcptr key, w = Hp - SIZEOF_StgWeak + WDS(1); SET_HDR(w, stg_WEAK_info, CCCS); - // We don't care about cfinalizer here. - // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or - // something else? - - StgWeak_key(w) = key; - StgWeak_value(w) = value; - StgWeak_finalizer(w) = finalizer; - StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure; + StgWeak_key(w) = key; + StgWeak_value(w) = value; + StgWeak_finalizer(w) = finalizer; + StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure; ACQUIRE_LOCK(sm_mutex); - StgWeak_link(w) = W_[weak_ptr_list]; - W_[weak_ptr_list] = w; + StgWeak_link(w) = generation_weak_ptr_list(W_[g0]); + generation_weak_ptr_list(W_[g0]) = w; RELEASE_LOCK(sm_mutex); IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w)); @@ -398,61 +394,62 @@ stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value ) jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure); } -stg_mkWeakForeignEnvzh ( gcptr key, - gcptr val, - W_ fptr, // finalizer - W_ ptr, - W_ flag, // has environment (0 or 1) - W_ eptr ) +STRING(stg_cfinalizer_msg,"Adding a finalizer to %p\n") + +stg_addCFinalizzerToWeakzh ( W_ fptr, // finalizer + W_ ptr, + W_ flag, // has environment (0 or 1) + W_ eptr, + gcptr w ) { - W_ payload_words, words; - gcptr w, p; + W_ c, info; - ALLOC_PRIM (SIZEOF_StgWeak); + LOCK_CLOSURE(w, info); - w = Hp - SIZEOF_StgWeak + WDS(1); - SET_HDR(w, stg_WEAK_info, CCCS); + if (info == stg_DEAD_WEAK_info) { + // Already dead. + unlockClosure(w, info); + return (0); + } - payload_words = 4; - words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words; - ("ptr" p) = ccall allocate(MyCapability() "ptr", words); + ALLOC_PRIM (SIZEOF_StgCFinalizerList) - TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0); - SET_HDR(p, stg_ARR_WORDS_info, CCCS); + c = Hp - SIZEOF_StgCFinalizerList + WDS(1); + SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS); - StgArrWords_bytes(p) = WDS(payload_words); - StgArrWords_payload(p,0) = fptr; - StgArrWords_payload(p,1) = ptr; - StgArrWords_payload(p,2) = eptr; - StgArrWords_payload(p,3) = flag; + StgCFinalizerList_fptr(c) = fptr; + StgCFinalizerList_ptr(c) = ptr; + StgCFinalizerList_eptr(c) = eptr; + StgCFinalizerList_flag(c) = flag; - // We don't care about the value here. - // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else? + StgCFinalizerList_link(c) = StgWeak_cfinalizers(w); + StgWeak_cfinalizers(w) = c; - StgWeak_key(w) = key; - StgWeak_value(w) = val; - StgWeak_finalizer(w) = stg_NO_FINALIZER_closure; - StgWeak_cfinalizer(w) = p; + unlockClosure(w, info); - ACQUIRE_LOCK(sm_mutex); - StgWeak_link(w) = W_[weak_ptr_list]; - W_[weak_ptr_list] = w; - RELEASE_LOCK(sm_mutex); + recordMutable(w); - IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w)); + IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w)); - return (w); + return (1); } stg_finalizzeWeakzh ( gcptr w ) { - gcptr f, arr; + gcptr f, list; + W_ info; + + LOCK_CLOSURE(w, info); // already dead? - if (GET_INFO(w) == stg_DEAD_WEAK_info) { + if (info == stg_DEAD_WEAK_info) { + unlockClosure(w, info); return (0,stg_NO_FINALIZER_closure); } + f = StgWeak_finalizer(w); + list = StgWeak_cfinalizers(w); + // kill it #ifdef PROFILING // @LDV profiling @@ -461,7 +458,7 @@ stg_finalizzeWeakzh ( gcptr w ) // LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w); // or, LDV_recordDead(): // LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader)); - // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as + // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as // large as weak pointers, so there is no need to fill the slop, either. // See stg_DEAD_WEAK_info in StgMiscClosures.hc. #endif @@ -469,19 +466,12 @@ stg_finalizzeWeakzh ( gcptr w ) // // Todo: maybe use SET_HDR() and remove LDV_recordCreate()? // - SET_INFO(w,stg_DEAD_WEAK_info); - LDV_RECORD_CREATE(w); - - f = StgWeak_finalizer(w); - arr = StgWeak_cfinalizer(w); + unlockClosure(w, stg_DEAD_WEAK_info); - StgDeadWeak_link(w) = StgWeak_link(w); + LDV_RECORD_CREATE(w); - if (arr != stg_NO_FINALIZER_closure) { - ccall runCFinalizer(StgArrWords_payload(arr,0), - StgArrWords_payload(arr,1), - StgArrWords_payload(arr,2), - StgArrWords_payload(arr,3)); + if (list != stg_NO_FINALIZER_closure) { + ccall runCFinalizers(list); } /* return the finalizer */ @@ -494,10 +484,21 @@ stg_finalizzeWeakzh ( gcptr w ) stg_deRefWeakzh ( gcptr w ) { - W_ code; + W_ code, info; gcptr val; - if (GET_INFO(w) == stg_WEAK_info) { + info = GET_INFO(w); + + if (info == stg_WHITEHOLE_info) { + // w is locked by another thread. Now it's not immediately clear if w is + // alive or not. We use lockClosure to wait for the info pointer to become + // something other than stg_WHITEHOLE_info. + + LOCK_CLOSURE(w, info); + unlockClosure(w, info); + } + + if (info == stg_WEAK_info) { code = 1; val = StgWeak_value(w); } else { @@ -512,7 +513,7 @@ stg_deRefWeakzh ( gcptr w ) -------------------------------------------------------------------------- */ stg_decodeFloatzuIntzh ( F_ arg ) -{ +{ W_ p; W_ mp_tmp1; W_ mp_tmp_w; @@ -521,16 +522,16 @@ stg_decodeFloatzuIntzh ( F_ arg ) mp_tmp1 = Sp - WDS(1); mp_tmp_w = Sp - WDS(2); - + /* Perform the operation */ ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg); - + /* returns: (Int# (mantissa), Int# (exponent)) */ return (W_[mp_tmp1], W_[mp_tmp_w]); } stg_decodeDoublezu2Intzh ( D_ arg ) -{ +{ W_ p; W_ mp_tmp1; W_ mp_tmp2; @@ -564,13 +565,13 @@ stg_forkzh ( gcptr closure ) gcptr threadid; - ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", - RtsFlags_GcFlags_initialStkSize(RtsFlags), + ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", + RtsFlags_GcFlags_initialStkSize(RtsFlags), closure "ptr"); /* start blocked if the current thread is blocked */ StgTSO_flags(threadid) = %lobits16( - TO_W_(StgTSO_flags(threadid)) | + TO_W_(StgTSO_flags(threadid)) | TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)); ccall scheduleThread(MyCapability() "ptr", threadid "ptr"); @@ -578,7 +579,7 @@ stg_forkzh ( gcptr closure ) // context switch soon, but not immediately: we don't want every // forkIO to force a context-switch. Capability_context_switch(MyCapability()) = 1 :: CInt; - + return (threadid); } @@ -588,13 +589,13 @@ again: MAYBE_GC(again); gcptr threadid; - ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", - RtsFlags_GcFlags_initialStkSize(RtsFlags), + ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", + RtsFlags_GcFlags_initialStkSize(RtsFlags), closure "ptr"); /* start blocked if the current thread is blocked */ StgTSO_flags(threadid) = %lobits16( - TO_W_(StgTSO_flags(threadid)) | + TO_W_(StgTSO_flags(threadid)) | TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)); ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr"); @@ -602,7 +603,7 @@ again: MAYBE_GC(again); // context switch soon, but not immediately: we don't want every // forkIO to force a context-switch. Capability_context_switch(MyCapability()) = 1 :: CInt; - + return (threadid); } @@ -1014,7 +1015,7 @@ retry_pop_stack: } } - // We've reached the ATOMICALLY_FRAME: attempt to wait + // We've reached the ATOMICALLY_FRAME: attempt to wait ASSERT(frame_type == ATOMICALLY_FRAME); if (outer != NO_TREC) { // We called retry while checking invariants, so abort the current @@ -1152,9 +1153,9 @@ stg_writeTVarzh (P_ tvar, /* :: TVar a */ stg_isEmptyMVarzh ( P_ mvar /* :: MVar a */ ) { if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { - return (1); + return (1); } else { - return (0); + return (0); } } @@ -1163,7 +1164,7 @@ stg_newMVarzh () W_ mvar; ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newMVarzh); - + mvar = Hp - SIZEOF_StgMVar + WDS(1); SET_HDR(mvar,stg_MVAR_DIRTY_info,CCCS); // MVARs start dirty: generation 0 has no mutable list @@ -1191,21 +1192,16 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) { W_ val, info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); - } + LOCK_CLOSURE(mvar, info); /* If the MVar is empty, put ourselves on its blocking queue, * and wait until we're woken up. */ if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { - + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + // We want to put the heap check down here in the slow path, // but be careful to unlock the closure before returning to // the RTS if the check fails. @@ -1220,30 +1216,32 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; - if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; - } else { + if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { + StgMVar_head(mvar) = q; + } else { StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); - } - StgTSO__link(CurrentTSO) = q; - StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; - StgMVar_tail(mvar) = q; - + } + StgTSO__link(CurrentTSO) = q; + StgTSO_block_info(CurrentTSO) = mvar; + StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + StgMVar_tail(mvar) = q; + jump stg_block_takemvar(mvar); } - + /* we got the value... */ val = StgMVar_value(mvar); - + q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { /* No further putMVars, MVar is now empty */ StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + // If the MVar is not already dirty, then we don't need to make + // it dirty, as it is empty with nothing blocking on it. + unlockClosure(mvar, info); return (val); } if (StgHeader_info(q) == stg_IND_info || @@ -1251,9 +1249,13 @@ loop: q = StgInd_indirectee(q); goto loop; } - + // There are putMVar(s) waiting... wake up the first thread on the queue - + + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { @@ -1270,11 +1272,11 @@ loop: // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - + // no need to mark the TSO dirty, we have only written END_TSO_QUEUE. ccall tryWakeupThread(MyCapability() "ptr", tso); - + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (val); } @@ -1283,48 +1285,43 @@ stg_tryTakeMVarzh ( P_ mvar /* :: MVar a */ ) { W_ val, info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif - - /* If the MVar is empty, put ourselves on its blocking queue, - * and wait until we're woken up. - */ + LOCK_CLOSURE(mvar, info); + + /* If the MVar is empty, return 0. */ if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { #if defined(THREADED_RTS) unlockClosure(mvar, info); #endif - /* HACK: we need a pointer to pass back, - * so we abuse NO_FINALIZER_closure - */ - return (0, stg_NO_FINALIZER_closure); - } - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + /* HACK: we need a pointer to pass back, + * so we abuse NO_FINALIZER_closure + */ + return (0, stg_NO_FINALIZER_closure); } /* we got the value... */ val = StgMVar_value(mvar); - + q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { /* No further putMVars, MVar is now empty */ StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + unlockClosure(mvar, info); return (1, val); } + if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { q = StgInd_indirectee(q); goto loop; } - + // There are putMVar(s) waiting... wake up the first thread on the queue - + + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { @@ -1341,11 +1338,11 @@ loop: // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - + // no need to mark the TSO dirty, we have only written END_TSO_QUEUE. ccall tryWakeupThread(MyCapability() "ptr", tso); - + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (1,val); } @@ -1355,18 +1352,14 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ { W_ info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); - } + LOCK_CLOSURE(mvar, info); if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) { + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + // We want to put the heap check down here in the slow path, // but be careful to unlock the closure before returning to // the RTS if the check fails. @@ -1381,27 +1374,30 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; - if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; - } else { + if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { + StgMVar_head(mvar) = q; + } else { StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); - } - StgTSO__link(CurrentTSO) = q; - StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; - StgMVar_tail(mvar) = q; + } + StgTSO__link(CurrentTSO) = q; + StgTSO_block_info(CurrentTSO) = mvar; + StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + StgMVar_tail(mvar) = q; jump stg_block_putmvar(mvar,val); } - + q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { - /* No further takes, the MVar is now full. */ - StgMVar_value(mvar) = val; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + /* No further takes, the MVar is now full. */ + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + StgMVar_value(mvar) = val; + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (); } if (StgHeader_info(q) == stg_IND_info || @@ -1410,16 +1406,19 @@ loop: goto loop; } - // There are takeMVar(s) waiting: wake up the first one - + // There are readMVar/takeMVar(s) waiting: wake up the first one + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); + // save why_blocked here, because waking up the thread destroys + // this information + W_ why_blocked; + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // actually perform the takeMVar W_ stack; @@ -1432,10 +1431,19 @@ loop: if (TO_W_(StgStack_dirty(stack)) == 0) { ccall dirty_STACK(MyCapability() "ptr", stack "ptr"); } - + ccall tryWakeupThread(MyCapability() "ptr", tso); - unlockClosure(mvar, stg_MVAR_DIRTY_info); + // If it was an readMVar, then we can still do work, + // so loop back. (XXX: This could take a while) + if (why_blocked == BlockedOnMVarRead) { + q = StgMVarTSOQueue_link(q); + goto loop; + } + + ASSERT(why_blocked == BlockedOnMVar); + + unlockClosure(mvar, info); return (); } @@ -1445,29 +1453,25 @@ stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */ { W_ info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif + LOCK_CLOSURE(mvar, info); if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) { #if defined(THREADED_RTS) - unlockClosure(mvar, info); + unlockClosure(mvar, info); #endif - return (0); - } - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + return (0); } q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { - /* No further takes, the MVar is now full. */ - StgMVar_value(mvar) = val; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + /* No further takes, the MVar is now full. */ + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + + StgMVar_value(mvar) = val; + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (1); } if (StgHeader_info(q) == stg_IND_info || @@ -1477,15 +1481,18 @@ loop: } // There are takeMVar(s) waiting: wake up the first one - + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); + // save why_blocked here, because waking up the thread destroys + // this information + W_ why_blocked; + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // actually perform the takeMVar W_ stack; @@ -1494,17 +1501,87 @@ loop: // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - + if (TO_W_(StgStack_dirty(stack)) == 0) { ccall dirty_STACK(MyCapability() "ptr", stack "ptr"); } - + ccall tryWakeupThread(MyCapability() "ptr", tso); - unlockClosure(mvar, stg_MVAR_DIRTY_info); + // If it was an readMVar, then we can still do work, + // so loop back. (XXX: This could take a while) + if (why_blocked == BlockedOnMVarRead) { + q = StgMVarTSOQueue_link(q); + goto loop; + } + + ASSERT(why_blocked == BlockedOnMVar); + + unlockClosure(mvar, info); return (1); } +stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) +{ + W_ val, info, tso, q; + + LOCK_CLOSURE(mvar, info); + + /* If the MVar is empty, put ourselves on the blocked readers + * list and wait until we're woken up. + */ + if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { + + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + + ALLOC_PRIM_WITH_CUSTOM_FAILURE + (SIZEOF_StgMVarTSOQueue, + unlockClosure(mvar, stg_MVAR_DIRTY_info); + GC_PRIM_P(stg_readMVarzh, mvar)); + + q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1); + + // readMVars are pushed to the front of the queue, so + // they get handled immediately + SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + StgMVarTSOQueue_link(q) = StgMVar_head(mvar); + StgMVarTSOQueue_tso(q) = CurrentTSO; + + StgTSO__link(CurrentTSO) = q; + StgTSO_block_info(CurrentTSO) = mvar; + StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16; + StgMVar_head(mvar) = q; + + if (StgMVar_tail(mvar) == stg_END_TSO_QUEUE_closure) { + StgMVar_tail(mvar) = q; + } + + jump stg_block_readmvar(mvar); + } + + val = StgMVar_value(mvar); + + unlockClosure(mvar, info); + return (val); +} + +stg_tryReadMVarzh ( P_ mvar, /* :: MVar a */ ) +{ + W_ val, info, tso, q; + + LOCK_CLOSURE(mvar, info); + + if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { + return (0, stg_NO_FINALIZER_closure); + } + + val = StgMVar_value(mvar); + + unlockClosure(mvar, info); + return (1, val); +} /* ----------------------------------------------------------------------------- Stable pointer primitives @@ -1566,23 +1643,23 @@ stg_newBCOzh ( P_ instrs, bco = Hp - bytes + WDS(1); SET_HDR(bco, stg_BCO_info, CCCS); - + StgBCO_instrs(bco) = instrs; StgBCO_literals(bco) = literals; StgBCO_ptrs(bco) = ptrs; StgBCO_arity(bco) = HALF_W_(arity); StgBCO_size(bco) = HALF_W_(words); - + // Copy the arity/bitmap info into the BCO W_ i; i = 0; for: if (i < BYTE_ARR_WDS(bitmap_arr)) { - StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i); - i = i + 1; - goto for; + StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i); + i = i + 1; + goto for; } - + return (bco); } @@ -1602,10 +1679,10 @@ stg_mkApUpd0zh ( P_ bco ) ap = Hp - SIZEOF_StgAP + WDS(1); SET_HDR(ap, stg_AP_info, CCCS); - + StgAP_n_args(ap) = HALF_W_(0); StgAP_fun(ap) = bco; - + return (ap); } @@ -1625,14 +1702,14 @@ stg_unpackClosurezh ( P_ closure ) nptrs = 0; goto out; } - case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, + case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : { ptrs = 0; nptrs = 0; goto out; } default: { - ptrs = TO_W_(%INFO_PTRS(info)); + ptrs = TO_W_(%INFO_PTRS(info)); nptrs = TO_W_(%INFO_NPTRS(info)); goto out; }} @@ -1658,22 +1735,22 @@ out: p = 0; for: if(p < ptrs) { - W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p); - p = p + 1; - goto for; + W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p); + p = p + 1; + goto for; } /* We can leave the card table uninitialised, since the array is allocated in the nursery. The GC will fill it in if/when the array is promoted. */ - + SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(nptrs_arr) = WDS(nptrs); p = 0; for2: if(p < nptrs) { - W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs); - p = p + 1; - goto for2; + W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs); + p = p + 1; + goto for2; } return (info, ptrs_arr, nptrs_arr); } @@ -1685,13 +1762,13 @@ for2: /* Add a thread to the end of the blocked queue. (C-- version of the C * macro in Schedule.h). */ -#define APPEND_TO_BLOCKED_QUEUE(tso) \ - ASSERT(StgTSO__link(tso) == END_TSO_QUEUE); \ - if (W_[blocked_queue_hd] == END_TSO_QUEUE) { \ - W_[blocked_queue_hd] = tso; \ - } else { \ +#define APPEND_TO_BLOCKED_QUEUE(tso) \ + ASSERT(StgTSO__link(tso) == END_TSO_QUEUE); \ + if (W_[blocked_queue_hd] == END_TSO_QUEUE) { \ + W_[blocked_queue_hd] = tso; \ + } else { \ ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \ - } \ + } \ W_[blocked_queue_tl] = tso; stg_waitReadzh ( W_ fd ) @@ -1748,7 +1825,7 @@ stg_delayzh ( W_ us_delay ) /* could probably allocate this on the heap instead */ ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, - stg_delayzh_malloc_str); + stg_delayzh_malloc_str); (reqID) = ccall addDelayRequest(us_delay); StgAsyncIOResult_reqID(ares) = reqID; StgAsyncIOResult_len(ares) = 0; @@ -1775,14 +1852,14 @@ stg_delayzh ( W_ us_delay ) t = W_[sleeping_queue]; while: if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) { - prev = t; - t = StgTSO__link(t); - goto while; + prev = t; + t = StgTSO__link(t); + goto while; } StgTSO__link(CurrentTSO) = t; if (prev == NULL) { - W_[sleeping_queue] = CurrentTSO; + W_[sleeping_queue] = CurrentTSO; } else { ccall setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO); } @@ -1896,7 +1973,7 @@ stg_asyncDoProczh ( W_ proc, W_ param ) * | -------+-----> A <-------+------- | * | update | BLACKHOLE | marked_update | * +-----------+ +---------------+ - * | | | | + * | | | | * ... ... * | | +---------------+ * +-----------+ @@ -1941,7 +2018,7 @@ stg_noDuplicatezh /* no arg list: explicit stack layout */ SAVE_THREAD_STATE(); ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16); ccall threadPaused (MyCapability() "ptr", CurrentTSO "ptr"); - + if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) { jump stg_threadFinished []; } else { diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index 11f518a87d..edc4a91193 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -294,6 +294,7 @@ check_target: } case BlockedOnMVar: + case BlockedOnMVarRead: { /* To establish ownership of this TSO, we need to acquire a @@ -318,7 +319,7 @@ check_target: // we have the MVar, let's check whether the thread // is still blocked on the same MVar. - if (target->why_blocked != BlockedOnMVar + if ((target->why_blocked != BlockedOnMVar && target->why_blocked != BlockedOnMVarRead) || (StgMVar *)target->block_info.closure != mvar) { unlockClosure((StgClosure *)mvar, info); goto retry; @@ -637,6 +638,7 @@ removeFromQueues(Capability *cap, StgTSO *tso) goto done; case BlockedOnMVar: + case BlockedOnMVarRead: removeFromMVarBlockedQueue(tso); goto done; diff --git a/rts/RaiseAsync.h b/rts/RaiseAsync.h index 336ab30e33..d804f6bc64 100644 --- a/rts/RaiseAsync.h +++ b/rts/RaiseAsync.h @@ -49,6 +49,7 @@ interruptible(StgTSO *t) { switch (t->why_blocked) { case BlockedOnMVar: + case BlockedOnMVarRead: case BlockedOnMsgThrowTo: case BlockedOnRead: case BlockedOnWrite: diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 4e7ed3e222..dc21149d98 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -1672,6 +1672,7 @@ inner_loop: retainClosure(tso->bq, c, c_child_r); retainClosure(tso->trec, c, c_child_r); if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo ) { @@ -1767,9 +1768,12 @@ computeRetainerSet( void ) // // The following code assumes that WEAK objects are considered to be roots // for retainer profilng. - for (weak = weak_ptr_list; weak != NULL; weak = weak->link) - // retainRoot((StgClosure *)weak); - retainRoot(NULL, (StgClosure **)&weak); + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + for (weak = generations[g].weak_ptr_list; weak != NULL; weak = weak->link) { + // retainRoot((StgClosure *)weak); + retainRoot(NULL, (StgClosure **)&weak); + } + } // Consider roots from the stable ptr table. markStableTables(retainRoot, NULL); diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c index ec19b169b6..720b732323 100644 --- a/rts/RtsAPI.c +++ b/rts/RtsAPI.c @@ -522,7 +522,16 @@ rts_checkSchedStatus (char* site, Capability *cap) stg_exit(EXIT_FAILURE); case Interrupted: errorBelch("%s: interrupted", site); - stg_exit(EXIT_FAILURE); +#ifdef THREADED_RTS + // The RTS is shutting down, and the process will probably + // soon exit. We don't want to preempt the shutdown + // by exiting the whole process here, so we just terminate the + // current thread. Don't forget to release the cap first though. + rts_unlock(cap); + shutdownThread(); +#else + stg_exit(EXIT_FAILURE); +#endif default: errorBelch("%s: Return code (%d) not ok",(site),(rc)); stg_exit(EXIT_FAILURE); diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 3f38c8ac1f..1e541a0201 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -52,7 +52,7 @@ wchar_t **win32_prog_argv = NULL; #endif /* - * constants, used later + * constants, used later */ #define RTS 1 #define PGM 0 @@ -111,9 +111,6 @@ void initRtsFlagsDefaults(void) RtsFlags.GcFlags.compact = rtsFalse; RtsFlags.GcFlags.compactThreshold = 30.0; RtsFlags.GcFlags.sweep = rtsFalse; -#ifdef RTS_GTK_FRONTPANEL - RtsFlags.GcFlags.frontpanel = rtsFalse; -#endif RtsFlags.GcFlags.idleGCDelayTime = USToTime(300000); // 300ms #ifdef THREADED_RTS RtsFlags.GcFlags.doIdleGC = rtsTrue; @@ -260,9 +257,6 @@ usage_text[] = { " -t[<file>] One-line GC statistics (if <file> omitted, uses stderr)", " -s[<file>] Summary GC statistics (if <file> omitted, uses stderr)", " -S[<file>] Detailed GC statistics (if <file> omitted, uses stderr)", -#ifdef RTS_GTK_FRONTPANEL -" -f Display front panel (requires X11 & GTK+)", -#endif "", "", " -Z Don't squeeze out update frames on stack overflow", @@ -292,7 +286,7 @@ usage_text[] = { " -hb<bio>... closures with specified biographies (lag,drag,void,use)", "", " -R<size> Set the maximum retainer set size (default: 8)", -"", +"", " -L<chars> Maximum length of a cost-centre stack in a heap profile", " (default: 25)", "", @@ -438,9 +432,9 @@ static void splitRtsFlags(const char *s) while (isspace(*c1)) { c1++; }; c2 = c1; while (!isspace(*c2) && *c2 != '\0') { c2++; }; - + if (c1 == c2) { break; } - + t = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()"); strncpy(t, c1, c2-c1); t[c2-c1] = '\0'; @@ -449,7 +443,7 @@ static void splitRtsFlags(const char *s) c1 = c2; } while (*c1 != '\0'); } - + /* ----------------------------------------------------------------------------- Parse the command line arguments, collecting options for the RTS. @@ -780,15 +774,15 @@ error = rtsTrue; case 'F': OPTION_UNSAFE; RtsFlags.GcFlags.oldGenFactor = atof(rts_argv[arg]+2); - + if (RtsFlags.GcFlags.oldGenFactor < 0) bad_option( rts_argv[arg] ); break; - + case 'D': OPTION_SAFE; DEBUG_BUILD_ONLY( - { + { char *c; for (c = rts_argv[arg] + 2; *c != '\0'; c++) { @@ -908,13 +902,6 @@ error = rtsTrue; } break; -#ifdef RTS_GTK_FRONTPANEL - case 'f': - OPTION_UNSAFE; - RtsFlags.GcFlags.frontpanel = rtsTrue; - break; -#endif - case 'I': /* idle GC delay */ OPTION_UNSAFE; if (rts_argv[arg][2] == '\0') { @@ -951,7 +938,7 @@ error = rtsTrue; goto stats; stats: - { + { int r; if (rts_argv[arg][2] != '\0') { OPTION_UNSAFE; @@ -1060,7 +1047,7 @@ error = rtsTrue; RtsFlags.ProfFlags.modSelector = left; break; case 'D': - case 'd': // closure descr select + case 'd': // closure descr select RtsFlags.ProfFlags.descrSelector = left; break; case 'Y': @@ -1114,12 +1101,12 @@ error = rtsTrue; break; } break; - + default: errorBelch("invalid heap profile option: %s",rts_argv[arg]); error = rtsTrue; } - ) + ) #endif /* PROFILING */ break; @@ -1266,7 +1253,7 @@ error = rtsTrue; RtsFlags.TickyFlags.showTickyStats = rtsTrue; - { + { int r; if (rts_argv[arg][2] != '\0') { OPTION_UNSAFE; @@ -1426,7 +1413,7 @@ static void normaliseRtsOpts (void) if (RtsFlags.ProfFlags.heapProfileInterval > 0) { RtsFlags.ProfFlags.heapProfileIntervalTicks = - RtsFlags.ProfFlags.heapProfileInterval / + RtsFlags.ProfFlags.heapProfileInterval / RtsFlags.MiscFlags.tickInterval; } else { RtsFlags.ProfFlags.heapProfileIntervalTicks = 0; @@ -1538,7 +1525,7 @@ decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max) m = atof(s); c = s[strlen(s)-1]; - if (c == 'g' || c == 'G') + if (c == 'g' || c == 'G') m *= 1024*1024*1024; else if (c == 'm' || c == 'M') m *= 1024*1024; @@ -1801,7 +1788,7 @@ void setWin32ProgArgv(int argc, wchar_t *argv[]) { int i; - + freeWin32ProgArgv(); win32_prog_argc = argc; @@ -1809,7 +1796,7 @@ setWin32ProgArgv(int argc, wchar_t *argv[]) win32_prog_argv = NULL; return; } - + win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *), "setWin32ProgArgv 1"); for (i = 0; i < argc; i++) { diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 7b7d488e2b..39c5ef1f94 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -38,10 +38,6 @@ #include "FileLock.h" void exitLinker( void ); // there is no Linker.h file to include -#if defined(RTS_GTK_FRONTPANEL) -#include "FrontPanel.h" -#endif - #if defined(PROFILING) # include "ProfHeap.h" # include "RetainerProfile.h" @@ -237,17 +233,11 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) initDefaultHandlers(); } #endif - + #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) startupAsyncIO(); #endif -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - initFrontPanel(); - } -#endif - #if X86_INIT_FPU x86_init_fpu(); #endif @@ -293,7 +283,7 @@ hs_add_root(void (*init_root)(void) STG_UNUSED) * False ==> threads doing foreign calls may return in the * future, but will immediately block on a mutex. * (capability->lock). - * + * * If this RTS is a DLL that we're about to unload, then you want * safe=True, otherwise the thread might return to code that has been * unloaded. If this is a standalone program that is about to exit, @@ -305,6 +295,8 @@ hs_add_root(void (*init_root)(void) STG_UNUSED) static void hs_exit_(rtsBool wait_foreign) { + nat g; + if (hs_init_count <= 0) { errorBelch("warning: too many hs_exit()s"); return; @@ -317,7 +309,7 @@ hs_exit_(rtsBool wait_foreign) /* start timing the shutdown */ stat_startExit(); - + OnExitHook(); flushStdHandles(); @@ -335,8 +327,10 @@ hs_exit_(rtsBool wait_foreign) exitScheduler(wait_foreign); /* run C finalizers for all active weak pointers */ - runAllCFinalizers(weak_ptr_list); - + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + runAllCFinalizers(generations[g].weak_ptr_list); + } + #if defined(RTS_USER_SIGNALS) if (RtsFlags.MiscFlags.install_signal_handlers) { freeSignalHandlers(); @@ -348,7 +342,7 @@ hs_exit_(rtsBool wait_foreign) exitTimer(wait_foreign); // set the terminal settings back to what they were -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) resetTerminalSettings(); #endif @@ -357,14 +351,14 @@ hs_exit_(rtsBool wait_foreign) /* stop timing the shutdown, we're about to print stats */ stat_endExit(); - + /* shutdown the hpc support (if needed) */ exitHpc(); // clean up things from the storage manager's point of view. // also outputs the stats (+RTS -s) info. exitStorage(); - + /* free the tasks */ freeScheduler(); @@ -385,13 +379,7 @@ hs_exit_(rtsBool wait_foreign) freeThreadLabelTable(); #endif -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - stopFrontPanel(); - } -#endif - -#if defined(PROFILING) +#if defined(PROFILING) reportCCSProfiling(); #endif @@ -479,15 +467,15 @@ shutdownHaskellAndSignal(int sig) } #endif -/* +/* * called from STG-land to exit the program */ void (*exitFn)(int) = 0; -void +void stg_exit(int n) -{ +{ if (exitFn) (*exitFn)(n); exit(n); diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index fcbb757c05..cb9002c361 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -137,26 +137,6 @@ heapOverflow(void) } /* ----------------------------------------------------------------------------- - genSym stuff, used by GHC itself for its splitting unique supply. - - ToDo: put this somewhere sensible. - ------------------------------------------------------------------------- */ - -static HsInt __GenSymCounter = 0; - -HsInt -genSymZh(void) -{ - return(__GenSymCounter++); -} -HsInt -resetGenSymZh(void) /* it's your funeral */ -{ - __GenSymCounter=0; - return(__GenSymCounter); -} - -/* ----------------------------------------------------------------------------- Get the current time as a string. Used in profiling reports. -------------------------------------------------------------------------- */ @@ -905,8 +905,12 @@ static StgBool check_read_only(StgTRecHeader *trec STG_UNUSED) { s = e -> tvar; if (entry_is_read_only(e)) { TRACE("%p : check_read_only for TVar %p, saw %ld", trec, s, e -> num_updates); - if (s -> num_updates != e -> num_updates) { - // ||s -> current_value != e -> expected_value) { + + // Note we need both checks and in this order as the TVar could be + // locked by another transaction that is committing but has not yet + // incremented `num_updates` (See #7815). + if (s -> current_value != e -> expected_value || + s -> num_updates != e -> num_updates) { TRACE("%p : mismatch", trec); result = FALSE; BREAK_FOR_EACH; diff --git a/rts/Schedule.c b/rts/Schedule.c index abd317cc62..408146f195 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -947,6 +947,7 @@ scheduleDetectDeadlock (Capability **pcap, Task *task) case BlockedOnBlackHole: case BlockedOnMsgThrowTo: case BlockedOnMVar: + case BlockedOnMVarRead: throwToSingleThreaded(cap, task->incall->tso, (StgClosure *)nonTermination_closure); return; @@ -1437,7 +1438,7 @@ scheduleDoGC (Capability **pcap, Task *task USED_IF_THREADS, rtsBool heap_census; nat collect_gen; #ifdef THREADED_RTS - rtsBool gc_type; + StgWord8 gc_type; nat i, sync; StgTSO *tso; #endif @@ -2722,7 +2723,19 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) tso->stackobj->sp = p; return STOP_FRAME; - case CATCH_RETRY_FRAME: + case CATCH_RETRY_FRAME: { + StgTRecHeader *trec = tso -> trec; + StgTRecHeader *outer = trec -> enclosing_trec; + debugTrace(DEBUG_stm, + "found CATCH_RETRY_FRAME at %p during raise", p); + debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer); + stmAbortTransaction(cap, trec); + stmFreeAbortedTRec(cap, trec); + tso -> trec = outer; + p = next; + continue; + } + default: p = next; continue; @@ -2831,6 +2844,7 @@ resurrectThreads (StgTSO *threads) switch (tso->why_blocked) { case BlockedOnMVar: + case BlockedOnMVarRead: /* Called by GC - sched_mutex lock is currently held. */ throwToSingleThreaded(cap, tso, (StgClosure *)blockedIndefinitelyOnMVar_closure); diff --git a/rts/StgCRun.c b/rts/StgCRun.c index f0fa6c7c5e..a45c52fd02 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -118,8 +118,10 @@ StgWord8 *win32AllocStack(void) #ifdef darwin_HOST_OS #define STG_GLOBAL ".globl " +#define STG_HIDDEN ".private_extern " #else #define STG_GLOBAL ".global " +#define STG_HIDDEN ".hidden " #endif /* @@ -164,6 +166,9 @@ StgRunIsImplementedInAssembler(void) { __asm__ volatile ( STG_GLOBAL STG_RUN "\n" +#if !defined(mingw32_HOST_OS) + STG_HIDDEN STG_RUN "\n" +#endif STG_RUN ":\n\t" /* @@ -236,7 +241,13 @@ StgRunIsImplementedInAssembler(void) #ifdef x86_64_HOST_ARCH -extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg); +#define STG_GLOBAL ".globl " + +#ifdef darwin_HOST_OS +#define STG_HIDDEN ".private_extern " +#else +#define STG_HIDDEN ".hidden " +#endif static void GNUC3_ATTRIBUTE(used) StgRunIsImplementedInAssembler(void) @@ -245,7 +256,10 @@ StgRunIsImplementedInAssembler(void) /* * save callee-saves registers on behalf of the STG code. */ - ".globl " STG_RUN "\n" + STG_GLOBAL STG_RUN "\n" +#if !defined(mingw32_HOST_OS) + STG_HIDDEN STG_RUN "\n" +#endif STG_RUN ":\n\t" "subq %1, %%rsp\n\t" "movq %%rsp, %%rax\n\t" @@ -400,7 +414,13 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { #ifdef powerpc_HOST_ARCH -extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg); +#define STG_GLOBAL ".globl " + +#ifdef darwin_HOST_OS +#define STG_HIDDEN ".private_extern " +#else +#define STG_HIDDEN ".hidden " +#endif #ifdef darwin_HOST_OS void StgRunIsImplementedInAssembler(void) @@ -408,11 +428,12 @@ void StgRunIsImplementedInAssembler(void) #if HAVE_SUBSECTIONS_VIA_SYMBOLS // if the toolchain supports deadstripping, we have to // prevent it here (it tends to get confused here). - __asm__ volatile (".no_dead_strip _StgRunIsImplementedInAssembler"); + __asm__ volatile (".no_dead_strip _StgRunIsImplementedInAssembler\n"); #endif __asm__ volatile ( - "\n.globl _StgRun\n" - "_StgRun:\n" + STG_GLOBAL STG_RUN "\n" + STG_HIDDEN STG_RUN "\n" + STG_RUN ":\n" "\tmflr r0\n" "\tbl saveFP # f14\n" "\tstmw r13,-220(r1)\n" @@ -446,6 +467,7 @@ StgRunIsImplementedInAssembler(void) { __asm__ volatile ( "\t.globl StgRun\n" + "\t.hidden StgRun\n" "\t.type StgRun,@function\n" "StgRun:\n" "\tmflr 0\n" @@ -518,8 +540,6 @@ StgRunIsImplementedInAssembler(void) #ifdef powerpc64_HOST_ARCH #ifdef linux_HOST_OS -extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg); - static void GNUC3_ATTRIBUTE(used) StgRunIsImplementedInAssembler(void) { @@ -534,6 +554,7 @@ StgRunIsImplementedInAssembler(void) ".section \".opd\",\"aw\"\n" ".align 3\n" ".globl StgRun\n" + ".hidden StgRun\n" "StgRun:\n" "\t.quad\t.StgRun,.TOC.@tocbase,0\n" "\t.size StgRun,24\n" diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 28a41ad681..9484031832 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -439,6 +439,15 @@ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,5,0,CONSTR,"DEAD_WEAK","DEAD_WEAK") { foreign "C" barf("DEAD_WEAK object entered!") never returns; } /* ---------------------------------------------------------------------------- + C finalizer lists + + Singly linked lists that chain multiple C finalizers on a weak pointer. + ------------------------------------------------------------------------- */ + +INFO_TABLE_CONSTR(stg_C_FINALIZER_LIST,1,4,0,CONSTR,"C_FINALIZER_LIST","C_FINALIZER_LIST") +{ foreign "C" barf("C_FINALIZER_LIST object entered!") never returns; } + +/* ---------------------------------------------------------------------------- NO_FINALIZER This is a static nullary constructor (like []) that we use to mark an empty diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c index e523f328c3..3b80d6f388 100644 --- a/rts/StgPrimFloat.c +++ b/rts/StgPrimFloat.c @@ -43,29 +43,6 @@ #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a))) -StgDouble -__2Int_encodeDouble (I_ j_high, I_ j_low, I_ e) -{ - StgDouble r; - - /* assuming 32 bit ints */ - ASSERT(sizeof(int ) == 4 ); - - r = (StgDouble)((unsigned int)j_high); - r *= 4294967296.0; /* exp2f(32); */ - r += (StgDouble)((unsigned int)j_low); - - /* Now raise to the exponent */ - if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ - r = ldexp(r, e); - - /* sign is encoded in the size */ - if (j_high < 0) - r = -r; - - return r; -} - /* Special version for words */ StgDouble __word_encodeDouble (W_ j, I_ e) diff --git a/rts/StgPrimFloat.h b/rts/StgPrimFloat.h index cd5da46326..edd7b472b7 100644 --- a/rts/StgPrimFloat.h +++ b/rts/StgPrimFloat.h @@ -14,11 +14,8 @@ /* grimy low-level support functions defined in StgPrimFloat.c */ void __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl); void __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt); -StgDouble __2Int_encodeDouble (I_ j_high, I_ j_low, I_ e); -StgDouble __word_encodeDouble (W_ j, I_ e); -StgFloat __word_encodeFloat (W_ j, I_ e); -// __int_encodeDouble and __int_encodeFloat are public, declared in +// __{int,word}_encode{Float,Double} are public, declared in // includes/rts/PrimFloat.h. #include "EndPrivate.h" diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm index 53e4cb1d23..979f7498ca 100644 --- a/rts/StgStdThunks.cmm +++ b/rts/StgStdThunks.cmm @@ -111,10 +111,10 @@ SELECTOR_CODE_UPD(15) UPD_BH_UPDATABLE(node); \ LDV_ENTER(node); \ selectee = StgThunk_payload(node,0); \ + ENTER_CCS_THUNK(node); \ if (NEED_EVAL(selectee)) { \ - ENTER_CCS_THUNK(node); \ SAVE_CCS; \ - (P_ constr) = call %GET_ENTRY(selectee) (selectee); \ + (P_ constr) = call %GET_ENTRY(UNTAG_IF_PROF(selectee)) (selectee); \ RESTORE_CCS; \ selectee = constr; \ } \ diff --git a/rts/Threads.c b/rts/Threads.c index b6176163ad..f2b800512e 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -84,7 +84,7 @@ createThread(Capability *cap, W_ size) stack_size = round_to_mblocks(size - sizeofW(StgTSO)); stack = (StgStack *)allocate(cap, stack_size); TICK_ALLOC_STACK(stack_size); - SET_HDR(stack, &stg_STACK_info, CCS_SYSTEM); + SET_HDR(stack, &stg_STACK_info, cap->r.rCCCS); stack->stack_size = stack_size - sizeofW(StgStack); stack->sp = stack->stack + stack->stack_size; stack->dirty = 1; @@ -255,6 +255,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso) switch (tso->why_blocked) { case BlockedOnMVar: + case BlockedOnMVarRead: { if (tso->_link == END_TSO_QUEUE) { tso->block_info.closure = (StgClosure*)END_TSO_QUEUE; @@ -575,7 +576,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso) chunk_size * sizeof(W_)); new_stack = (StgStack*) allocate(cap, chunk_size); - SET_HDR(new_stack, &stg_STACK_info, CCS_SYSTEM); + SET_HDR(new_stack, &stg_STACK_info, old_stack->header.prof.ccs); TICK_ALLOC_STACK(chunk_size); new_stack->dirty = 0; // begin clean, we'll mark it dirty below @@ -734,6 +735,9 @@ printThreadBlockage(StgTSO *tso) case BlockedOnMVar: debugBelch("is blocked on an MVar @ %p", tso->block_info.closure); break; + case BlockedOnMVarRead: + debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure); + break; case BlockedOnBlackHole: debugBelch("is blocked on a black hole %p", ((StgBlockingQueue*)tso->block_info.bh->bh)); diff --git a/rts/Ticky.c b/rts/Ticky.c index 0d33c43d79..e1e981b6df 100644 --- a/rts/Ticky.c +++ b/rts/Ticky.c @@ -75,7 +75,8 @@ PrintTickyInfo(void) tot_adm_wds + tot_gds_wds + tot_slp_wds; #endif - unsigned long tot_thk_enters = ENT_STATIC_THK_ctr + ENT_DYN_THK_ctr; + unsigned long tot_thk_enters = ENT_STATIC_THK_MANY_ctr + ENT_DYN_THK_MANY_ctr + + ENT_STATIC_THK_SINGLE_ctr + ENT_DYN_THK_SINGLE_ctr; unsigned long tot_con_enters = ENT_STATIC_CON_ctr + ENT_DYN_CON_ctr; unsigned long tot_fun_direct_enters = ENT_STATIC_FUN_DIRECT_ctr + ENT_DYN_FUN_DIRECT_ctr; @@ -452,8 +453,12 @@ PrintTickyInfo(void) PR_CTR(ENT_PAP_ctr); PR_CTR(ENT_AP_STACK_ctr); PR_CTR(ENT_BH_ctr); - PR_CTR(ENT_STATIC_THK_ctr); - PR_CTR(ENT_DYN_THK_ctr); + PR_CTR(ENT_STATIC_THK_SINGLE_ctr); + PR_CTR(ENT_STATIC_THK_MANY_ctr); + PR_CTR(ENT_DYN_THK_SINGLE_ctr); + PR_CTR(ENT_DYN_THK_MANY_ctr); + PR_CTR(UPD_CAF_BH_UPDATABLE_ctr); + PR_CTR(UPD_CAF_BH_SINGLE_ENTRY_ctr); PR_CTR(SLOW_CALL_fast_v16_ctr); PR_CTR(SLOW_CALL_fast_v_ctr); @@ -547,10 +552,6 @@ PrintTickyInfo(void) PR_CTR(UPD_PAP_IN_NEW_ctr); PR_CTR(UPD_PAP_IN_PLACE_ctr); - PR_CTR(UPD_BH_UPDATABLE_ctr); - PR_CTR(UPD_BH_SINGLE_ENTRY_ctr); - PR_CTR(UPD_CAF_BH_UPDATABLE_ctr); - PR_CTR(UPD_CAF_BH_SINGLE_ENTRY_ctr); /* krc: put off till later...*/ #if FALSE diff --git a/rts/Trace.c b/rts/Trace.c index 78dfead450..21901891cb 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -179,6 +179,7 @@ static char *thread_stop_reasons[] = { [ThreadFinished] = "finished", [THREAD_SUSPENDED_FOREIGN_CALL] = "suspended while making a foreign call", [6 + BlockedOnMVar] = "blocked on an MVar", + [6 + BlockedOnMVarRead] = "blocked on an atomic MVar read", [6 + BlockedOnBlackHole] = "blocked on a black hole", [6 + BlockedOnRead] = "blocked on a read operation", [6 + BlockedOnWrite] = "blocked on a write operation", diff --git a/rts/Weak.c b/rts/Weak.c index 5546514243..98ac7603b7 100644 --- a/rts/Weak.c +++ b/rts/Weak.c @@ -16,18 +16,19 @@ #include "Prelude.h" #include "Trace.h" -// ForeignPtrs with C finalizers rely on weak pointers inside weak_ptr_list -// to always be in the same order. - -StgWeak *weak_ptr_list; - void -runCFinalizer(void *fn, void *ptr, void *env, StgWord flag) +runCFinalizers(StgCFinalizerList *list) { - if (flag) - ((void (*)(void *, void *))fn)(env, ptr); - else - ((void (*)(void *))fn)(ptr); + StgCFinalizerList *head; + for (head = list; + (StgClosure *)head != &stg_NO_FINALIZER_closure; + head = (StgCFinalizerList *)head->link) + { + if (head->flag) + ((void (*)(void *, void *))head->fptr)(head->eptr, head->ptr); + else + ((void (*)(void *))head->fptr)(head->ptr); + } } void @@ -42,15 +43,7 @@ runAllCFinalizers(StgWeak *list) } for (w = list; w; w = w->link) { - StgArrWords *farr; - - farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer); - - if ((StgClosure *)farr != &stg_NO_FINALIZER_closure) - runCFinalizer((void *)farr->payload[0], - (void *)farr->payload[1], - (void *)farr->payload[2], - farr->payload[3]); + runCFinalizers((StgCFinalizerList *)w->cfinalizers); } if (task != NULL) { @@ -91,8 +84,6 @@ scheduleFinalizers(Capability *cap, StgWeak *list) // count number of finalizers, and kill all the weak pointers first... n = 0; for (w = list; w; w = w->link) { - StgArrWords *farr; - // Better not be a DEAD_WEAK at this stage; the garbage // collector removes DEAD_WEAKs from the weak pointer list. ASSERT(w->header.info != &stg_DEAD_WEAK_info); @@ -101,13 +92,7 @@ scheduleFinalizers(Capability *cap, StgWeak *list) n++; } - farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer); - - if ((StgClosure *)farr != &stg_NO_FINALIZER_closure) - runCFinalizer((void *)farr->payload[0], - (void *)farr->payload[1], - (void *)farr->payload[2], - farr->payload[3]); + runCFinalizers((StgCFinalizerList *)w->cfinalizers); #ifdef PROFILING // A weak pointer is inherently used, so we do not need to call diff --git a/rts/Weak.h b/rts/Weak.h index 9b230f94de..fbdf18a861 100644 --- a/rts/Weak.h +++ b/rts/Weak.h @@ -14,9 +14,9 @@ #include "BeginPrivate.h" extern rtsBool running_finalizers; -extern StgWeak * weak_ptr_list; +extern StgWeak * dead_weak_ptr_list; -void runCFinalizer(void *fn, void *ptr, void *env, StgWord flag); +void runCFinalizers(StgCFinalizerList *list); void runAllCFinalizers(StgWeak *w); void scheduleFinalizers(Capability *cap, StgWeak *w); void markWeakList(void); diff --git a/rts/ghc.mk b/rts/ghc.mk index b7651b09cf..4cc8e8de34 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -24,7 +24,7 @@ rts_WAYS = $(GhcLibWays) $(filter-out $(GhcLibWays),$(GhcRTSWays)) rts_dist_WAYS = $(rts_WAYS) ALL_RTS_LIBS = $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf)) -all_rts : $(ALL_RTS_LIBS) +$(eval $(call all-target,rts,$(ALL_RTS_LIBS))) # ----------------------------------------------------------------------------- # Defining the sources @@ -68,10 +68,14 @@ DTRACEPROBES_H = rts/dist/build/RtsProbes.h rts_H_FILES += $(DTRACEPROBES_H) endif -# collect the -l flags that we need to link the rts dyn lib. -rts/libs.depend : $$(ghc-pkg_INPLACE) - "$(ghc-pkg_INPLACE)" field rts extra-libraries \ - | sed -e 's/^extra-libraries: //' -e 's/\([a-z0-9]*\)[ ]*/-l\1 /g' > $@ +# collect the -l and -L flags that we need to link the rts dyn lib. +# Note that, as sed on OS X doesn't handle \+, we use [^ ][^ ]* rather +# than [^ ]\+ +rts/dist/libs.depend : $$(ghc-pkg_INPLACE) | $$(dir $$@)/. + "$(ghc-pkg_INPLACE)" --simple-output field rts extra-libraries \ + | sed -e 's/\([^ ][^ ]*\)/-l\1/g' > $@ + "$(ghc-pkg_INPLACE)" --simple-output field rts library-dirs \ + | sed -e 's/\([^ ][^ ]*\)/-L\1/g' >> $@ # ---------------------------------------------------------------------------- @@ -105,13 +109,13 @@ endif ifneq "$(BINDIST)" "YES" ifneq "$(UseSystemLibFFI)" "YES" ifeq "$(HostOS_CPP)" "mingw32" -rts/dist/build/libffi.dll: libffi/build/inst/bin/$(LIBFFI_DLL) +rts/dist/build/$(LIBFFI_DLL): libffi/build/inst/bin/$(LIBFFI_DLL) cp $< $@ else # This is a little hacky. We don't know the SO version, so we only # depend on libffi.so, but copy libffi.so* -rts/dist/build/libffi$(soext): libffi/build/inst/lib/libffi$(soext) - cp libffi/build/inst/lib/libffi$(soext)* rts/dist/build +rts/dist/build/lib$(LIBFFI_NAME)$(soext): libffi/build/inst/lib/lib$(LIBFFI_NAME)$(soext) + cp libffi/build/inst/lib/lib$(LIBFFI_NAME)$(soext)* rts/dist/build endif endif endif @@ -170,7 +174,7 @@ endif rts_dist_$1_CC_OPTS += -DRtsWay=\"rts_$1\" ifneq "$$(UseSystemLibFFI)" "YES" -rts_dist_FFI_SO = rts/dist/build/libffi$$(soext) +rts_dist_FFI_SO = rts/dist/build/lib$$(LIBFFI_NAME)$$(soext) else rts_dist_FFI_SO = endif @@ -178,26 +182,28 @@ endif # Making a shared library for the RTS. ifneq "$$(findstring dyn, $1)" "" ifeq "$$(HostOS_CPP)" "mingw32" -$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) rts/libs.depend rts/dist/build/libffi.dll +$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) rts/dist/libs.depend rts/dist/build/$$(LIBFFI_DLL) "$$(RM)" $$(RM_OPTS) $$@ "$$(rts_dist_HC)" -package-name rts -shared -dynamic -dynload deploy \ - -no-auto-link-packages -Lrts/dist/build -lffi `cat rts/libs.depend` $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) -o $$@ + -no-auto-link-packages -Lrts/dist/build -l$$(LIBFFI_NAME) \ + `cat rts/dist/libs.depend` $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) -o $$@ else ifneq "$$(UseSystemLibFFI)" "YES" -LIBFFI_LIBS = -Lrts/dist/build -lffi +LIBFFI_LIBS = -Lrts/dist/build -l$$(LIBFFI_NAME) ifeq "$$(TargetElf)" "YES" -LIBFFI_LIBS += -optl-Wl,-rpath -optl-Wl,'$$$$ORIGIN' +LIBFFI_LIBS += -optl-Wl,-rpath -optl-Wl,'$$$$ORIGIN' -optl-Wl,-z -optl-Wl,origin endif else -# flags will be taken care of in rts/libs.depend +# flags will be taken care of in rts/dist/libs.depend LIBFFI_LIBS = endif -$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) rts/libs.depend $$(rts_dist_FFI_SO) +$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) rts/dist/libs.depend $$(rts_dist_FFI_SO) "$$(RM)" $$(RM_OPTS) $$@ "$$(rts_dist_HC)" -package-name rts -shared -dynamic -dynload deploy \ - -no-auto-link-packages $$(LIBFFI_LIBS) `cat rts/libs.depend` $$(rts_$1_OBJS) \ + -no-auto-link-packages $$(LIBFFI_LIBS) `cat rts/dist/libs.depend` $$(rts_$1_OBJS) \ $$(rts_$1_DTRACE_OBJS) -o $$@ + $(call relative-dynlib-references,rts,dist,1) endif else $$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) @@ -206,8 +212,8 @@ $$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) $$(AR_OPTS_STAGE1) $$(EXTRA_AR_ARGS_STAGE1) $$@ ifneq "$$(UseSystemLibFFI)" "YES" -$$(rts_$1_LIB) : rts/dist/build/libCffi$$($1_libsuf) -rts/dist/build/libCffi$$($1_libsuf): libffi/build/inst/lib/libffi.a +$$(rts_$1_LIB) : rts/dist/build/libC$$(LIBFFI_NAME)$$($1_libsuf) +rts/dist/build/libC$$(LIBFFI_NAME)$$($1_libsuf): libffi/build/inst/lib/libffi.a cp $$< $$@ endif @@ -220,7 +226,7 @@ endef # And expand the above for each way: $(foreach way,$(rts_WAYS),$(eval $(call build-rts-way,$(way)))) -$(eval $(call distdir-opts,rts,dist)) +$(eval $(call distdir-opts,rts,dist,1)) #----------------------------------------------------------------------------- # Flags for compiling every file @@ -418,7 +424,9 @@ rts/win32/ThrIOManager_CC_OPTS += -w # for details # Without this, thread_obj will not be inlined (at least on x86 with GCC 4.1.0) +ifneq "$(CC_CLANG_BACKEND)" "1" rts/sm/Compact_CC_OPTS += -finline-limit=2500 +endif # -O3 helps unroll some loops (especially in copy() with a constant argument). rts/sm/Evac_CC_OPTS += -funroll-loops @@ -469,7 +477,7 @@ else # UseSystemLibFFI==YES rts_PACKAGE_CPP_OPTS += -DFFI_INCLUDE_DIR= rts_PACKAGE_CPP_OPTS += -DFFI_LIB_DIR= -rts_PACKAGE_CPP_OPTS += '-DFFI_LIB="Cffi"' +rts_PACKAGE_CPP_OPTS += '-DFFI_LIB="C$(LIBFFI_NAME)"' endif @@ -479,9 +487,12 @@ endif rts_WAYS_DASHED = $(subst $(space),,$(patsubst %,-%,$(strip $(rts_WAYS)))) rts_dist_depfile_base = rts/dist/build/.depend$(rts_WAYS_DASHED) -rts_dist_C_SRCS = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS) -rts_dist_S_SRCS = $(rts_S_SRCS) -rts_dist_C_FILES = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS) $(rts_S_SRCS) +rts_dist_C_SRCS = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS) +rts_dist_S_SRCS = $(rts_S_SRCS) +rts_dist_CMM_SRCS = $(rts_CMM_SRCS) +rts_dist_C_FILES = $(rts_dist_C_SRCS) +rts_dist_S_FILES = $(rts_dist_S_SRCS) +rts_dist_CMM_FILES = $(rts_dist_CMM_SRCS) # Hack: we define every way-related option here, so that we get (hopefully) # a superset of the dependencies. To do this properly, we should generate @@ -549,8 +560,8 @@ rts/package.conf.inplace : $(includes_H_CONFIG) $(includes_H_PLATFORM) RTS_INSTALL_LIBS += $(ALL_RTS_LIBS) ifneq "$(UseSystemLibFFI)" "YES" -RTS_INSTALL_LIBS += $(wildcard rts/dist/build/libffi*$(soext)*) -RTS_INSTALL_LIBS += $(foreach w,$(filter-out %dyn,$(rts_WAYS)),rts/dist/build/libCffi$($w_libsuf)) +RTS_INSTALL_LIBS += $(wildcard rts/dist/build/lib$(LIBFFI_NAME)*$(soext)*) +RTS_INSTALL_LIBS += $(foreach w,$(filter-out %dyn,$(rts_WAYS)),rts/dist/build/libC$(LIBFFI_NAME)$($w_libsuf)) endif ifneq "$(UseSystemLibFFI)" "YES" diff --git a/rts/package.conf.in b/rts/package.conf.in index 9aef05dbb5..010305f83d 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -3,12 +3,12 @@ #include "ghcconfig.h" #include "rts/Config.h" -name: rts -version: 1.0 +name: rts +version: 1.0 id: builtin_rts -license: BSD3 -maintainer: glasgow-haskell-users@haskell.org -exposed: True +license: BSD3 +maintainer: glasgow-haskell-users@haskell.org +exposed: True exposed-modules: hidden-modules: @@ -16,33 +16,36 @@ hidden-modules: import-dirs: #ifdef INSTALLING -library-dirs: LIB_DIR"/rts-1.0" PAPI_LIB_DIR +library-dirs: LIB_DIR"/rts-1.0" PAPI_LIB_DIR FFI_LIB_DIR #else /* !INSTALLING */ -library-dirs: TOP"/rts/dist/build" PAPI_LIB_DIR +library-dirs: TOP"/rts/dist/build" PAPI_LIB_DIR FFI_LIB_DIR #endif hs-libraries: "HSrts" FFI_LIB extra-libraries: #ifdef HAVE_LIBM - "m" /* for ldexp() */ + "m" /* for ldexp() */ #endif #ifdef HAVE_LIBRT - , "rt" + , "rt" #endif #ifdef HAVE_LIBDL - , "dl" + , "dl" #endif #ifdef HAVE_LIBFFI , "ffi" #endif #ifdef mingw32_HOST_OS - ,"wsock32" /* for the linker */ - ,"gdi32" /* for the linker */ - ,"winmm" /* for the linker */ + ,"wsock32" /* for the linker */ + ,"gdi32" /* for the linker */ + ,"winmm" /* for the linker */ +#endif +#ifdef freebsd_HOST_OS + , "pthread" /* for pthread_getthreadid_np() */ #endif #if defined(DEBUG) && defined(HAVE_LIBBFD) - ,"bfd", "iberty" /* for debugging */ + ,"bfd", "iberty" /* for debugging */ #endif #ifdef HAVE_LIBMINGWEX # ifndef INSTALLING /* Bundled Mingw is behind */ @@ -50,100 +53,100 @@ extra-libraries: # endif #endif #if USE_PAPI - , "papi" + , "papi" #endif #ifdef INSTALLING -include-dirs: INCLUDE_DIR PAPI_INCLUDE_DIR +include-dirs: INCLUDE_DIR PAPI_INCLUDE_DIR #else /* !INSTALLING */ include-dirs: TOP"/rts/dist/build" TOP"/includes" TOP"/includes/dist-derivedconstants/header" #endif -includes: Stg.h +includes: Stg.h hugs-options: cc-options: ld-options: #ifdef LEADING_UNDERSCORE - "-u", "_ghczmprim_GHCziTypes_Izh_static_info" - , "-u", "_ghczmprim_GHCziTypes_Czh_static_info" - , "-u", "_ghczmprim_GHCziTypes_Fzh_static_info" - , "-u", "_ghczmprim_GHCziTypes_Dzh_static_info" - , "-u", "_base_GHCziPtr_Ptr_static_info" - , "-u", "_ghczmprim_GHCziTypes_Wzh_static_info" - , "-u", "_base_GHCziInt_I8zh_static_info" - , "-u", "_base_GHCziInt_I16zh_static_info" - , "-u", "_base_GHCziInt_I32zh_static_info" - , "-u", "_base_GHCziInt_I64zh_static_info" - , "-u", "_base_GHCziWord_W8zh_static_info" - , "-u", "_base_GHCziWord_W16zh_static_info" - , "-u", "_base_GHCziWord_W32zh_static_info" - , "-u", "_base_GHCziWord_W64zh_static_info" - , "-u", "_base_GHCziStable_StablePtr_static_info" - , "-u", "_ghczmprim_GHCziTypes_Izh_con_info" - , "-u", "_ghczmprim_GHCziTypes_Czh_con_info" - , "-u", "_ghczmprim_GHCziTypes_Fzh_con_info" - , "-u", "_ghczmprim_GHCziTypes_Dzh_con_info" - , "-u", "_base_GHCziPtr_Ptr_con_info" - , "-u", "_base_GHCziPtr_FunPtr_con_info" - , "-u", "_base_GHCziStable_StablePtr_con_info" - , "-u", "_ghczmprim_GHCziTypes_False_closure" - , "-u", "_ghczmprim_GHCziTypes_True_closure" - , "-u", "_base_GHCziPack_unpackCString_closure" - , "-u", "_base_GHCziIOziException_stackOverflow_closure" - , "-u", "_base_GHCziIOziException_heapOverflow_closure" - , "-u", "_base_ControlziExceptionziBase_nonTermination_closure" - , "-u", "_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" - , "-u", "_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" - , "-u", "_base_ControlziExceptionziBase_nestedAtomically_closure" - , "-u", "_base_GHCziWeak_runFinalizzerBatch_closure" - , "-u", "_base_GHCziTopHandler_flushStdHandles_closure" - , "-u", "_base_GHCziTopHandler_runIO_closure" - , "-u", "_base_GHCziTopHandler_runNonIO_closure" - , "-u", "_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" - , "-u", "_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" - , "-u", "_base_GHCziConcziSync_runSparks_closure" - , "-u", "_base_GHCziConcziSignal_runHandlers_closure" + "-Wl,-u,_ghczmprim_GHCziTypes_Izh_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Czh_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Fzh_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Dzh_static_info" + , "-Wl,-u,_base_GHCziPtr_Ptr_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Wzh_static_info" + , "-Wl,-u,_base_GHCziInt_I8zh_static_info" + , "-Wl,-u,_base_GHCziInt_I16zh_static_info" + , "-Wl,-u,_base_GHCziInt_I32zh_static_info" + , "-Wl,-u,_base_GHCziInt_I64zh_static_info" + , "-Wl,-u,_base_GHCziWord_W8zh_static_info" + , "-Wl,-u,_base_GHCziWord_W16zh_static_info" + , "-Wl,-u,_base_GHCziWord_W32zh_static_info" + , "-Wl,-u,_base_GHCziWord_W64zh_static_info" + , "-Wl,-u,_base_GHCziStable_StablePtr_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Izh_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Czh_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Fzh_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Dzh_con_info" + , "-Wl,-u,_base_GHCziPtr_Ptr_con_info" + , "-Wl,-u,_base_GHCziPtr_FunPtr_con_info" + , "-Wl,-u,_base_GHCziStable_StablePtr_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_False_closure" + , "-Wl,-u,_ghczmprim_GHCziTypes_True_closure" + , "-Wl,-u,_base_GHCziPack_unpackCString_closure" + , "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure" + , "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure" + , "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure" + , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" + , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + , "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" + , "-Wl,-u,_base_GHCziWeak_runFinalizzerBatch_closure" + , "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" + , "-Wl,-u,_base_GHCziTopHandler_runIO_closure" + , "-Wl,-u,_base_GHCziTopHandler_runNonIO_closure" + , "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" + , "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" + , "-Wl,-u,_base_GHCziConcziSignal_runHandlers_closure" #else - "-u", "ghczmprim_GHCziTypes_Izh_static_info" - , "-u", "ghczmprim_GHCziTypes_Czh_static_info" - , "-u", "ghczmprim_GHCziTypes_Fzh_static_info" - , "-u", "ghczmprim_GHCziTypes_Dzh_static_info" - , "-u", "base_GHCziPtr_Ptr_static_info" - , "-u", "ghczmprim_GHCziTypes_Wzh_static_info" - , "-u", "base_GHCziInt_I8zh_static_info" - , "-u", "base_GHCziInt_I16zh_static_info" - , "-u", "base_GHCziInt_I32zh_static_info" - , "-u", "base_GHCziInt_I64zh_static_info" - , "-u", "base_GHCziWord_W8zh_static_info" - , "-u", "base_GHCziWord_W16zh_static_info" - , "-u", "base_GHCziWord_W32zh_static_info" - , "-u", "base_GHCziWord_W64zh_static_info" - , "-u", "base_GHCziStable_StablePtr_static_info" - , "-u", "ghczmprim_GHCziTypes_Izh_con_info" - , "-u", "ghczmprim_GHCziTypes_Czh_con_info" - , "-u", "ghczmprim_GHCziTypes_Fzh_con_info" - , "-u", "ghczmprim_GHCziTypes_Dzh_con_info" - , "-u", "base_GHCziPtr_Ptr_con_info" - , "-u", "base_GHCziPtr_FunPtr_con_info" - , "-u", "base_GHCziStable_StablePtr_con_info" - , "-u", "ghczmprim_GHCziTypes_False_closure" - , "-u", "ghczmprim_GHCziTypes_True_closure" - , "-u", "base_GHCziPack_unpackCString_closure" - , "-u", "base_GHCziIOziException_stackOverflow_closure" - , "-u", "base_GHCziIOziException_heapOverflow_closure" - , "-u", "base_ControlziExceptionziBase_nonTermination_closure" - , "-u", "base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" - , "-u", "base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" - , "-u", "base_ControlziExceptionziBase_nestedAtomically_closure" - , "-u", "base_GHCziWeak_runFinalizzerBatch_closure" - , "-u", "base_GHCziTopHandler_flushStdHandles_closure" - , "-u", "base_GHCziTopHandler_runIO_closure" - , "-u", "base_GHCziTopHandler_runNonIO_closure" - , "-u", "base_GHCziConcziIO_ensureIOManagerIsRunning_closure" - , "-u", "base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" - , "-u", "base_GHCziConcziSync_runSparks_closure" - , "-u", "base_GHCziConcziSignal_runHandlers_closure" + "-Wl,-u,ghczmprim_GHCziTypes_Izh_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Czh_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Fzh_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Dzh_static_info" + , "-Wl,-u,base_GHCziPtr_Ptr_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Wzh_static_info" + , "-Wl,-u,base_GHCziInt_I8zh_static_info" + , "-Wl,-u,base_GHCziInt_I16zh_static_info" + , "-Wl,-u,base_GHCziInt_I32zh_static_info" + , "-Wl,-u,base_GHCziInt_I64zh_static_info" + , "-Wl,-u,base_GHCziWord_W8zh_static_info" + , "-Wl,-u,base_GHCziWord_W16zh_static_info" + , "-Wl,-u,base_GHCziWord_W32zh_static_info" + , "-Wl,-u,base_GHCziWord_W64zh_static_info" + , "-Wl,-u,base_GHCziStable_StablePtr_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Izh_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Czh_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Fzh_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Dzh_con_info" + , "-Wl,-u,base_GHCziPtr_Ptr_con_info" + , "-Wl,-u,base_GHCziPtr_FunPtr_con_info" + , "-Wl,-u,base_GHCziStable_StablePtr_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_False_closure" + , "-Wl,-u,ghczmprim_GHCziTypes_True_closure" + , "-Wl,-u,base_GHCziPack_unpackCString_closure" + , "-Wl,-u,base_GHCziIOziException_stackOverflow_closure" + , "-Wl,-u,base_GHCziIOziException_heapOverflow_closure" + , "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure" + , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" + , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + , "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" + , "-Wl,-u,base_GHCziWeak_runFinalizzerBatch_closure" + , "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" + , "-Wl,-u,base_GHCziTopHandler_runIO_closure" + , "-Wl,-u,base_GHCziTopHandler_runNonIO_closure" + , "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" + , "-Wl,-u,base_GHCziConcziSync_runSparks_closure" + , "-Wl,-u,base_GHCziConcziSignal_runHandlers_closure" #endif /* Pick up static libraries in preference over dynamic if in earlier search @@ -151,7 +154,7 @@ ld-options: * The used option is specific to the Darwin linker. */ #ifdef darwin_HOST_OS - , "-Wl,-search_paths_first" + , "-Wl,-search_paths_first" #endif #if defined(darwin_HOST_OS) && !defined(x86_64_HOST_ARCH) diff --git a/rts/posix/Itimer.c b/rts/posix/Itimer.c index b99ff8970b..4bcc3a1c2e 100644 --- a/rts/posix/Itimer.c +++ b/rts/posix/Itimer.c @@ -45,6 +45,20 @@ #include <string.h> /* + * timer_create doesn't exist and setitimer doesn't fire on iOS, so we're using + * a pthreads-based implementation. It may be to do with interference with the + * signals of the debugger. Revisit. See #7723. + */ +#if defined(ios_HOST_OS) +#define USE_PTHREAD_FOR_ITIMER +#endif + +#if defined(USE_PTHREAD_FOR_ITIMER) +#include <pthread.h> +#include <unistd.h> +#endif + +/* * We use a realtime timer by default. I found this much more * reliable than a CPU timer: * @@ -107,6 +121,7 @@ static timer_t timer; static Time itimer_interval = DEFAULT_TICK_INTERVAL; +#if !defined(USE_PTHREAD_FOR_ITIMER) static void install_vtalrm_handler(TickProc handle_tick) { struct sigaction action; @@ -132,13 +147,33 @@ static void install_vtalrm_handler(TickProc handle_tick) stg_exit(EXIT_FAILURE); } } +#endif + +#if defined(USE_PTHREAD_FOR_ITIMER) +static volatile int itimer_enabled; +static void *itimer_thread_func(void *_handle_tick) +{ + TickProc handle_tick = _handle_tick; + while (1) { + usleep(TimeToUS(itimer_interval)); + switch (itimer_enabled) { + case 1: handle_tick(0); break; + case 2: itimer_enabled = 0; + } + } + return NULL; +} +#endif void initTicker (Time interval, TickProc handle_tick) { itimer_interval = interval; -#if defined(USE_TIMER_CREATE) +#if defined(USE_PTHREAD_FOR_ITIMER) + pthread_t tid; + pthread_create(&tid, NULL, itimer_thread_func, (void*)handle_tick); +#elif defined(USE_TIMER_CREATE) { struct sigevent ev; @@ -153,15 +188,18 @@ initTicker (Time interval, TickProc handle_tick) stg_exit(EXIT_FAILURE); } } -#endif - install_vtalrm_handler(handle_tick); +#else + install_vtalrm_handler(handle_tick); +#endif } void startTicker(void) { -#if defined(USE_TIMER_CREATE) +#if defined(USE_PTHREAD_FOR_ITIMER) + itimer_enabled = 1; +#elif defined(USE_TIMER_CREATE) { struct itimerspec it; @@ -193,7 +231,14 @@ startTicker(void) void stopTicker(void) { -#if defined(USE_TIMER_CREATE) +#if defined(USE_PTHREAD_FOR_ITIMER) + if (itimer_enabled == 1) { + itimer_enabled = 2; + /* Wait for the thread to confirm it won't generate another tick. */ + while (itimer_enabled != 0) + sched_yield(); + } +#elif defined(USE_TIMER_CREATE) struct itimerspec it; it.it_value.tv_sec = 0; diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 7c89418ab9..247f1a01c6 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -442,6 +442,7 @@ thread_TSO (StgTSO *tso) thread_(&tso->global_link); if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo || tso->why_blocked == NotBlocked @@ -620,7 +621,7 @@ thread_obj (StgInfoTable *info, StgPtr p) case WEAK: { StgWeak *w = (StgWeak *)p; - thread(&w->cfinalizer); + thread(&w->cfinalizers); thread(&w->key); thread(&w->value); thread(&w->finalizer); @@ -917,17 +918,20 @@ compact(StgClosure *static_objects) markScheduler((evac_fn)thread_root, NULL); // the weak pointer lists... - if (weak_ptr_list != NULL) { - thread((void *)&weak_ptr_list); + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + if (generations[g].weak_ptr_list != NULL) { + thread((void *)&generations[g].weak_ptr_list); + } } - if (old_weak_ptr_list != NULL) { - thread((void *)&old_weak_ptr_list); // tmp + + if (dead_weak_ptr_list != NULL) { + thread((void *)&dead_weak_ptr_list); // tmp } // mutable lists for (g = 1; g < RtsFlags.GcFlags.generations; g++) { - bdescr *bd; - StgPtr p; + bdescr *bd; + StgPtr p; for (n = 0; n < n_capabilities; n++) { for (bd = capabilities[n].mut_lists[g]; bd != NULL; bd = bd->link) { diff --git a/rts/sm/GC.c b/rts/sm/GC.c index dfebd55334..1b2cb12212 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -6,7 +6,7 @@ * * Documentation on the architecture of the Garbage Collector can be * found in the online commentary: - * + * * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC * * ---------------------------------------------------------------------------*/ @@ -41,15 +41,13 @@ #include "Prelude.h" #include "RtsSignals.h" #include "STM.h" -#if defined(RTS_GTK_FRONTPANEL) -#include "FrontPanel.h" -#endif #include "Trace.h" #include "RetainerProfile.h" #include "LdvProfile.h" #include "RaiseAsync.h" #include "Papi.h" #include "Stable.h" +#include "CheckUnload.h" #include <string.h> // for memset() #include <unistd.h> @@ -75,13 +73,13 @@ * linking objects on to the list. We use a stack-type list, consing * objects on the front as they are added (this means that the * scavenge phase is depth-first, not breadth-first, but that - * shouldn't matter). + * shouldn't matter). * * A separate list is kept for objects that have been scavenged * already - this is so that we can zero all the marks afterwards. * * An object is on the list if its static link field is non-zero; this - * means that we have to mark the end of the list with '1', not NULL. + * means that we have to mark the end of the list with '1', not NULL. * * Extra notes for generational GC: * @@ -103,7 +101,7 @@ rtsBool major_gc; /* Data used for allocation area sizing. */ -static W_ g0_pcnt_kept = 30; // percentage of g0 live at last minor GC +static W_ g0_pcnt_kept = 30; // percentage of g0 live at last minor GC /* Mut-list stats */ #ifdef DEBUG @@ -216,7 +214,7 @@ GarbageCollect (nat collect_gen, // this is the main thread SET_GCT(gc_threads[cap->no]); - // tell the stats department that we've started a GC + // tell the stats department that we've started a GC stat_startGC(cap, gct); // lock the StablePtr table @@ -235,7 +233,7 @@ GarbageCollect (nat collect_gen, mutlist_OTHERS = 0; #endif - // attribute any costs to CCS_GC + // attribute any costs to CCS_GC #ifdef PROFILING for (n = 0; n < n_capabilities; n++) { save_CCS[n] = capabilities[n].r.rCCCS; @@ -254,7 +252,7 @@ GarbageCollect (nat collect_gen, // It's not always a good idea to do load balancing in parallel // GC. In particular, for a parallel program we don't want to // lose locality by moving cached data into another CPU's cache - // (this effect can be quite significant). + // (this effect can be quite significant). // // We could have a more complex way to deterimine whether to do // work stealing or not, e.g. it might be a good idea to do it @@ -283,14 +281,8 @@ GarbageCollect (nat collect_gen, debugTrace(DEBUG_gc, "GC (gen %d, using %d thread(s))", N, n_gc_threads); -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - updateFrontPanelBeforeGC(N); - } -#endif - #ifdef DEBUG - // check for memory leaks if DEBUG is on + // check for memory leaks if DEBUG is on memInventory(DEBUG_gc); #endif @@ -401,10 +393,10 @@ GarbageCollect (nat collect_gen, scavenge_until_all_done(); // The other threads are now stopped. We might recurse back to // here, but from now on this is the only thread. - + // must be last... invariant is that everything is fully // scavenged at this point. - if (traverseWeakPtrList()) { // returns rtsTrue if evaced something + if (traverseWeakPtrList()) { // returns rtsTrue if evaced something inc_running(); continue; } @@ -451,7 +443,7 @@ GarbageCollect (nat collect_gen, // Finally: compact or sweep the oldest generation. if (major_gc && oldest_gen->mark) { - if (oldest_gen->compact) + if (oldest_gen->compact) compact(gct->scavenged_static_objects); else sweep(oldest_gen); @@ -460,7 +452,7 @@ GarbageCollect (nat collect_gen, copied = 0; par_max_copied = 0; par_tot_copied = 0; - { + { nat i; for (i=0; i < n_gc_threads; i++) { if (n_gc_threads > 1) { @@ -494,7 +486,7 @@ GarbageCollect (nat collect_gen, for (g = 0; g < RtsFlags.GcFlags.generations; g++) { if (g == N) { - generations[g].collections++; // for stats + generations[g].collections++; // for stats if (n_gc_threads > 1) generations[g].par_collections++; } @@ -521,7 +513,7 @@ GarbageCollect (nat collect_gen, bdescr *next, *prev; gen = &generations[g]; - // for generations we collected... + // for generations we collected... if (g <= N) { /* free old memory and shift to-space into from-space for all @@ -532,12 +524,12 @@ GarbageCollect (nat collect_gen, { // tack the new blocks on the end of the existing blocks if (gen->old_blocks != NULL) { - + prev = NULL; for (bd = gen->old_blocks; bd != NULL; bd = next) { - + next = bd->link; - + if (!(bd->flags & BF_MARKED)) { if (prev == NULL) { @@ -551,17 +543,17 @@ GarbageCollect (nat collect_gen, else { gen->n_words += bd->free - bd->start; - + // NB. this step might not be compacted next // time, so reset the BF_MARKED flags. // They are set before GC if we're going to // compact. (search for BF_MARKED above). bd->flags &= ~BF_MARKED; - + // between GCs, all blocks in the heap except // for the nursery have the BF_EVACUATED flag set. bd->flags |= BF_EVACUATED; - + prev = bd; } } @@ -606,8 +598,8 @@ GarbageCollect (nat collect_gen, dbl_link_onto(bd, &gen->large_objects); gen->n_large_words += bd->free - bd->start; } - - // add the new blocks we promoted during this GC + + // add the new blocks we promoted during this GC gen->n_large_blocks += gen->n_scavenged_large_blocks; } @@ -634,7 +626,7 @@ GarbageCollect (nat collect_gen, // update the max size of older generations after a major GC resize_generations(); - + // Free the mark stack. if (mark_stack_top_bd != NULL) { debugTrace(DEBUG_gc, "mark stack: %d blocks", @@ -670,11 +662,15 @@ GarbageCollect (nat collect_gen, resetNurseries(); + if (major_gc) { + checkUnload (gct->scavenged_static_objects); + } + // mark the garbage collected CAFs as dead -#if 0 && defined(DEBUG) // doesn't work at the moment +#if 0 && defined(DEBUG) // doesn't work at the moment if (major_gc) { gcCAFs(); } #endif - + #ifdef PROFILING // resetStaticObjectForRetainerProfiling() must be called before // zeroing below. @@ -683,7 +679,7 @@ GarbageCollect (nat collect_gen, resetStaticObjectForRetainerProfiling(gct->scavenged_static_objects); #endif - // zero the scavenged static object list + // zero the scavenged static object list if (major_gc) { nat i; if (n_gc_threads == 1) { @@ -708,7 +704,7 @@ GarbageCollect (nat collect_gen, // Start any pending finalizers. Must be after // updateStableTables() and stableUnlock() (see #4221). RELEASE_SM_LOCK; - scheduleFinalizers(cap, old_weak_ptr_list); + scheduleFinalizers(cap, dead_weak_ptr_list); ACQUIRE_SM_LOCK; // check sanity after GC @@ -750,11 +746,11 @@ GarbageCollect (nat collect_gen, IF_DEBUG(gc, statDescribeGens()); #ifdef DEBUG - // symbol-table based profiling + // symbol-table based profiling /* heapCensus(to_blocks); */ /* ToDo */ #endif - // restore enclosing cost centre + // restore enclosing cost centre #ifdef PROFILING for (n = 0; n < n_capabilities; n++) { capabilities[n].r.rCCCS = save_CCS[n]; @@ -762,17 +758,11 @@ GarbageCollect (nat collect_gen, #endif #ifdef DEBUG - // check for memory leaks if DEBUG is on + // check for memory leaks if DEBUG is on memInventory(DEBUG_gc); #endif -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - updateFrontPanelAfterGC( N, live ); - } -#endif - - // ok, GC over: tell the stats department what happened. + // ok, GC over: tell the stats department what happened. stat_endGC(cap, gct, live_words, copied, live_blocks * BLOCK_SIZE_W - live_words /* slop */, N, n_gc_threads, par_max_copied, par_tot_copied); @@ -821,7 +811,7 @@ new_gc_thread (nat n, gc_thread *t) t->gc_count = 0; init_gc_thread(t); - + #ifdef USE_PAPI t->papi_events = -1; #endif @@ -832,7 +822,7 @@ new_gc_thread (nat n, gc_thread *t) ws->gen = &generations[g]; ASSERT(g == ws->gen->no); ws->my_gct = t; - + // We want to call // alloc_todo_block(ws,0); // but can't, because it uses gct which isn't set up at this point. @@ -960,7 +950,7 @@ any_work (void) if (mark_stack_bd != NULL && !mark_stack_empty()) { return rtsTrue; } - + // Check for global work in any step. We don't need to check for // local work, because we have already exited scavenge_loop(), // which means there is no local work for this thread. @@ -991,13 +981,13 @@ any_work (void) #endif return rtsFalse; -} +} static void scavenge_until_all_done (void) { DEBUG_ONLY( nat r ); - + loop: #if defined(THREADED_RTS) @@ -1023,7 +1013,7 @@ loop: traceEventGcIdle(gct->cap); debugTrace(DEBUG_gc, "%d GC threads still running", r); - + while (gc_running_threads != 0) { // usleep(1); if (any_work()) { @@ -1033,10 +1023,10 @@ loop: } // any_work() does not remove the work from the queue, it // just checks for the presence of work. If we find any, - // then we increment gc_running_threads and go back to + // then we increment gc_running_threads and go back to // scavenge_loop() to perform any pending work. } - + traceEventGcDone(gct->cap); } @@ -1065,7 +1055,7 @@ gcWorkerThread (Capability *cap) gct->wakeup = GC_THREAD_STANDING_BY; debugTrace(DEBUG_gc, "GC thread %d standing by...", gct->thread_index); ACQUIRE_SPIN_LOCK(&gct->gc_spin); - + #ifdef USE_PAPI // start performance counters in this thread... if (gct->papi_events == -1) { @@ -1084,7 +1074,7 @@ gcWorkerThread (Capability *cap) scavenge_capability_mut_lists(cap); scavenge_until_all_done(); - + if (!DEBUG_IS_ON) { clearNursery(cap); } @@ -1107,7 +1097,7 @@ gcWorkerThread (Capability *cap) // Wait until we're told to continue RELEASE_SPIN_LOCK(&gct->gc_spin); gct->wakeup = GC_THREAD_WAITING_TO_CONTINUE; - debugTrace(DEBUG_gc, "GC thread %d waiting to continue...", + debugTrace(DEBUG_gc, "GC thread %d waiting to continue...", gct->thread_index); ACQUIRE_SPIN_LOCK(&gct->mut_spin); debugTrace(DEBUG_gc, "GC thread %d on my way...", gct->thread_index); @@ -1213,7 +1203,7 @@ releaseGCThreads (Capability *cap USED_IF_THREADS) if (i == me || gc_threads[i]->idle) continue; if (gc_threads[i]->wakeup != GC_THREAD_WAITING_TO_CONTINUE) barf("releaseGCThreads"); - + gc_threads[i]->wakeup = GC_THREAD_INACTIVE; ACQUIRE_SPIN_LOCK(&gc_threads[i]->gc_spin); RELEASE_SPIN_LOCK(&gc_threads[i]->mut_spin); @@ -1222,7 +1212,7 @@ releaseGCThreads (Capability *cap USED_IF_THREADS) #endif /* ---------------------------------------------------------------------------- - Initialise a generation that is to be collected + Initialise a generation that is to be collected ------------------------------------------------------------------------- */ static void @@ -1293,7 +1283,7 @@ prepare_collected_gen (generation *gen) for (bd = gen->old_blocks; bd; bd = bd->link) { bd->flags &= ~BF_EVACUATED; } - + // mark the large objects as from-space for (bd = gen->large_objects; bd; bd = bd->link) { bd->flags &= ~BF_EVACUATED; @@ -1304,7 +1294,7 @@ prepare_collected_gen (generation *gen) StgWord bitmap_size; // in bytes bdescr *bitmap_bdescr; StgWord *bitmap; - + bitmap_size = gen->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE); if (bitmap_size > 0) { @@ -1312,19 +1302,19 @@ prepare_collected_gen (generation *gen) / BLOCK_SIZE); gen->bitmap = bitmap_bdescr; bitmap = bitmap_bdescr->start; - + debugTrace(DEBUG_gc, "bitmap_size: %d, bitmap: %p", bitmap_size, bitmap); - + // don't forget to fill it with zeros! memset(bitmap, 0, bitmap_size); - + // For each block in this step, point to its bitmap from the // block descriptor. for (bd=gen->old_blocks; bd != NULL; bd = bd->link) { bd->u.bitmap = bitmap; bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE); - + // Also at this point we set the BF_MARKED flag // for this block. The invariant is that // BF_MARKED is always unset, except during GC @@ -1355,7 +1345,7 @@ stash_mut_list (Capability *cap, nat gen_no) } /* ---------------------------------------------------------------------------- - Initialise a generation that is *not* to be collected + Initialise a generation that is *not* to be collected ------------------------------------------------------------------------- */ static void @@ -1388,10 +1378,10 @@ collect_gct_blocks (void) nat g; gen_workspace *ws; bdescr *bd, *prev; - + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { ws = &gct->gens[g]; - + // there may still be a block attached to ws->todo_bd; // leave it there to use next time. @@ -1400,7 +1390,7 @@ collect_gct_blocks (void) ASSERT(gct->scan_bd == NULL); ASSERT(countBlocks(ws->scavd_list) == ws->n_scavd_blocks); - + prev = NULL; for (bd = ws->scavd_list; bd != NULL; bd = bd->link) { ws->gen->n_words += bd->free - bd->start; @@ -1409,7 +1399,7 @@ collect_gct_blocks (void) if (prev != NULL) { prev->link = ws->gen->blocks; ws->gen->blocks = ws->scavd_list; - } + } ws->gen->n_blocks += ws->n_scavd_blocks; ws->scavd_list = NULL; @@ -1492,9 +1482,9 @@ mark_root(void *user USED_IF_THREADS, StgClosure **root) saved_gct = gct; #endif SET_GCT(user); - + evacuate(root); - + SET_GCT(saved_gct); } @@ -1519,7 +1509,7 @@ zero_static_object_list(StgClosure* first_static) /* ---------------------------------------------------------------------------- Reset the sizes of the older generations when we do a major collection. - + CURRENT STRATEGY: make all generations except zero the same size. We have to stay within the maximum heap size, and leave a certain percentage of the maximum heap size available to allocate into. @@ -1534,7 +1524,7 @@ resize_generations (void) W_ live, size, min_alloc, words; const W_ max = RtsFlags.GcFlags.maxHeapSize; const W_ gens = RtsFlags.GcFlags.generations; - + // live in the oldest generations if (oldest_gen->live_estimate != 0) { words = oldest_gen->live_estimate; @@ -1543,11 +1533,11 @@ resize_generations (void) } live = (words + BLOCK_SIZE_W - 1) / BLOCK_SIZE_W + oldest_gen->n_large_blocks; - + // default max size for all generations except zero size = stg_max(live * RtsFlags.GcFlags.oldGenFactor, RtsFlags.GcFlags.minOldGenSize); - + if (RtsFlags.GcFlags.heapSizeSuggestionAuto) { if (max > 0) { RtsFlags.GcFlags.heapSizeSuggestion = stg_min(max, size); @@ -1564,7 +1554,7 @@ resize_generations (void) // certain percentage of the maximum heap size (default: 30%). if (RtsFlags.GcFlags.compact || (max > 0 && - oldest_gen->n_blocks > + oldest_gen->n_blocks > (RtsFlags.GcFlags.compactThreshold * max) / 100)) { oldest_gen->mark = 1; oldest_gen->compact = 1; @@ -1584,14 +1574,14 @@ resize_generations (void) // different if compaction is turned on, because we don't need // to double the space required to collect the old generation. if (max != 0) { - + // this test is necessary to ensure that the calculations // below don't have any negative results - we're working // with unsigned values here. if (max < min_alloc) { heapOverflow(); } - + if (oldest_gen->compact) { if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) { size = (max - min_alloc) / ((gens - 1) * 2 - 1); @@ -1601,17 +1591,17 @@ resize_generations (void) size = (max - min_alloc) / ((gens - 1) * 2); } } - + if (size < live) { heapOverflow(); } } - + #if 0 debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live, min_alloc, size, max); #endif - + for (g = 0; g < gens; g++) { generations[g].max_blocks = size; } @@ -1630,7 +1620,7 @@ resize_nursery (void) if (RtsFlags.GcFlags.generations == 1) { // Two-space collector: W_ blocks; - + /* set up a new nursery. Allocate a nursery size based on a * function of the amount of live data (by default a factor of 2) * Use the blocks from the old nursery if possible, freeing up any @@ -1640,25 +1630,25 @@ resize_nursery (void) * size accordingly. If the nursery is the same size as the live * data (L), then we need 3L bytes. We can reduce the size of the * nursery to bring the required memory down near 2L bytes. - * + * * A normal 2-space collector would need 4L bytes to give the same * performance we get from 3L bytes, reducing to the same * performance at 2L bytes. */ blocks = generations[0].n_blocks; - + if ( RtsFlags.GcFlags.maxHeapSize != 0 && - blocks * RtsFlags.GcFlags.oldGenFactor * 2 > + blocks * RtsFlags.GcFlags.oldGenFactor * 2 > RtsFlags.GcFlags.maxHeapSize ) { - long adjusted_blocks; // signed on purpose - int pc_free; - + long adjusted_blocks; // signed on purpose + int pc_free; + adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks); - - debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", + + debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks); - + pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize; if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even * be < 0 */ { @@ -1678,7 +1668,7 @@ resize_nursery (void) } else // Generational collector { - /* + /* * If the user has given us a suggested heap size, adjust our * allocation area to make best use of the memory available. */ @@ -1688,7 +1678,7 @@ resize_nursery (void) StgWord needed; calcNeeded(rtsFalse, &needed); // approx blocks needed at next GC - + /* Guess how much will be live in generation 0 step 0 next time. * A good approximation is obtained by finding the * percentage of g0 that was live at the last minor GC. @@ -1703,7 +1693,7 @@ resize_nursery (void) g0_pcnt_kept = ((copied / (BLOCK_SIZE_W - 10)) * 100) / countNurseryBlocks(); } - + /* Estimate a size for the allocation area based on the * information available. We might end up going slightly under * or over the suggested heap size, but we should be pretty @@ -1716,14 +1706,14 @@ resize_nursery (void) * where 'needed' is the amount of memory needed at the next * collection for collecting all gens except g0. */ - blocks = + blocks = (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) / (100 + (long)g0_pcnt_kept); - + if (blocks < (long)min_nursery) { blocks = min_nursery; } - + resizeNurseries((W_)blocks); } else @@ -1744,7 +1734,7 @@ resize_nursery (void) whenever the program tries to enter a garbage collected CAF. Any garbage collected CAFs are taken off the CAF list at the same - time. + time. -------------------------------------------------------------------------- */ #if 0 && defined(DEBUG) @@ -1762,14 +1752,14 @@ gcCAFs(void) pp = &caf_list; while (p != NULL) { - + info = get_itbl(p); ASSERT(info->type == IND_STATIC); if (STATIC_LINK(info,p) == NULL) { debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p); - // black hole it + // black hole it SET_INFO(p,&stg_BLACKHOLE_info); p = STATIC_LINK2(info,p); *pp = p; @@ -1782,6 +1772,6 @@ gcCAFs(void) } - debugTrace(DEBUG_gccafs, "%d CAFs live", i); + debugTrace(DEBUG_gccafs, "%d CAFs live", i); } #endif diff --git a/rts/sm/GCThread.h b/rts/sm/GCThread.h index 7aacb4eb51..748b0687fa 100644 --- a/rts/sm/GCThread.h +++ b/rts/sm/GCThread.h @@ -122,7 +122,7 @@ typedef struct gc_thread_ { OSThreadId id; // The OS thread that this struct belongs to SpinLock gc_spin; SpinLock mut_spin; - volatile rtsBool wakeup; + volatile StgWord8 wakeup; #endif nat thread_index; // a zero based index identifying the thread rtsBool idle; // sitting out of this GC cycle diff --git a/rts/sm/GCUtils.c b/rts/sm/GCUtils.c index 996b5f6280..d8633f98ea 100644 --- a/rts/sm/GCUtils.c +++ b/rts/sm/GCUtils.c @@ -161,6 +161,7 @@ push_scanned_block (bdescr *bd, gen_workspace *ws) StgPtr todo_block_full (nat size, gen_workspace *ws) { + rtsBool urgent_to_push, can_extend; StgPtr p; bdescr *bd; @@ -174,20 +175,49 @@ todo_block_full (nat size, gen_workspace *ws) ASSERT(bd->link == NULL); ASSERT(bd->gen == ws->gen); - // If the global list is not empty, or there's not much work in - // this block to push, and there's enough room in - // this block to evacuate the current object, then just increase - // the limit. - if (!looksEmptyWSDeque(ws->todo_q) || - (ws->todo_free - bd->u.scan < WORK_UNIT_WORDS / 2)) { - if (ws->todo_free + size < bd->start + bd->blocks * BLOCK_SIZE_W) { - ws->todo_lim = stg_min(bd->start + bd->blocks * BLOCK_SIZE_W, - ws->todo_lim + stg_max(WORK_UNIT_WORDS,size)); - debugTrace(DEBUG_gc, "increasing limit for %p to %p", bd->start, ws->todo_lim); - p = ws->todo_free; - ws->todo_free += size; - return p; - } + // We intentionally set ws->todo_lim lower than the full size of + // the block, so that we can push out some work to the global list + // and get the parallel threads working as soon as possible. + // + // So when ws->todo_lim is reached, we end up here and have to + // decide whether it's worth pushing out the work we have or not. + // If we have enough room in the block to evacuate the current + // object, and it's not urgent to push this work, then we just + // extend the limit and keep going. Where "urgent" is defined as: + // the global pool is empty, and there's enough work in this block + // to make it worth pushing. + // + urgent_to_push = + looksEmptyWSDeque(ws->todo_q) && + (ws->todo_free - bd->u.scan >= WORK_UNIT_WORDS / 2); + + // We can extend the limit for the current block if there's enough + // room for the current object, *and* we're not into the second or + // subsequent block of a large block. The second condition occurs + // when we evacuate an object that is larger than a block. In + // that case, alloc_todo_block() sets todo_lim to be exactly the + // size of the large object, and we don't evacuate any more + // objects into this block. The reason is that the rest of the GC + // is not set up to handle objects that start in the second or + // later blocks of a group. We just about manage this in the + // nursery (see scheduleHandleHeapOverflow()) so evacuate() can + // handle this, but other parts of the GC can't. We could + // probably fix this, but it's a rare case anyway. + // + can_extend = + ws->todo_free + size <= bd->start + bd->blocks * BLOCK_SIZE_W + && ws->todo_free < ws->todo_bd->start + BLOCK_SIZE_W; + + if (!urgent_to_push && can_extend) + { + ws->todo_lim = stg_min(bd->start + bd->blocks * BLOCK_SIZE_W, + ws->todo_lim + stg_max(WORK_UNIT_WORDS,size)); + debugTrace(DEBUG_gc, "increasing limit for %p to %p", + bd->start, ws->todo_lim); + p = ws->todo_free; + ws->todo_free += size; + + return p; } gct->copied += ws->todo_free - bd->free; @@ -201,12 +231,19 @@ todo_block_full (nat size, gen_workspace *ws) { // If this block does not have enough space to allocate the // current object, but it also doesn't have any work to push, then - // push it on to the scanned list. It cannot be empty, because - // then there would be enough room to copy the current object. + // push it on to the scanned list. if (bd->u.scan == bd->free) { - ASSERT(bd->free != bd->start); - push_scanned_block(bd, ws); + if (bd->free == bd->start) { + // Normally the block would not be empty, because then + // there would be enough room to copy the current + // object. However, if the object we're copying is + // larger than a block, then we might have an empty + // block here. + freeGroup(bd); + } else { + push_scanned_block(bd, ws); + } } // Otherwise, push this block out to the global list. else diff --git a/rts/sm/MarkStack.h b/rts/sm/MarkStack.h index db79ca4520..e2319a544d 100644 --- a/rts/sm/MarkStack.h +++ b/rts/sm/MarkStack.h @@ -12,7 +12,7 @@ * ---------------------------------------------------------------------------*/ #ifndef SM_MARKSTACK_H -#define SM_MARKSTACk_H +#define SM_MARKSTACK_H #include "BeginPrivate.h" diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c index d57f7a094b..f0ab5d19d7 100644 --- a/rts/sm/MarkWeak.c +++ b/rts/sm/MarkWeak.c @@ -75,164 +75,133 @@ typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage; static WeakStage weak_stage; -/* Weak pointers - */ -StgWeak *old_weak_ptr_list; // also pending finaliser list -StgWeak *weak_ptr_list_tail; +// List of weak pointers whose key is dead +StgWeak *dead_weak_ptr_list; // List of threads found to be unreachable StgTSO *resurrected_threads; -static void resurrectUnreachableThreads (generation *gen); -static rtsBool tidyThreadList (generation *gen); +static void collectDeadWeakPtrs (generation *gen); +static rtsBool tidyWeakList (generation *gen); +static rtsBool resurrectUnreachableThreads (generation *gen); +static void tidyThreadList (generation *gen); void initWeakForGC(void) { - old_weak_ptr_list = weak_ptr_list; - weak_ptr_list = NULL; - weak_ptr_list_tail = NULL; - weak_stage = WeakPtrs; + nat g; + + for (g = 0; g <= N; g++) { + generation *gen = &generations[g]; + gen->old_weak_ptr_list = gen->weak_ptr_list; + gen->weak_ptr_list = NULL; + } + + weak_stage = WeakThreads; + dead_weak_ptr_list = NULL; resurrected_threads = END_TSO_QUEUE; } rtsBool traverseWeakPtrList(void) { - StgWeak *w, **last_w, *next_w; - StgClosure *new; rtsBool flag = rtsFalse; - const StgInfoTable *info; switch (weak_stage) { case WeakDone: return rtsFalse; - case WeakPtrs: - /* doesn't matter where we evacuate values/finalizers to, since - * these pointers are treated as roots (iff the keys are alive). - */ - gct->evac_gen_no = 0; - - last_w = &old_weak_ptr_list; - for (w = old_weak_ptr_list; w != NULL; w = next_w) { - - /* There might be a DEAD_WEAK on the list if finalizeWeak# was - * called on a live weak pointer object. Just remove it. - */ - if (w->header.info == &stg_DEAD_WEAK_info) { - next_w = ((StgDeadWeak *)w)->link; - *last_w = next_w; - continue; - } - - info = get_itbl((StgClosure *)w); - switch (info->type) { - - case WEAK: - /* Now, check whether the key is reachable. - */ - new = isAlive(w->key); - if (new != NULL) { - w->key = new; - // evacuate the value and finalizer - evacuate(&w->value); - evacuate(&w->finalizer); - // remove this weak ptr from the old_weak_ptr list - *last_w = w->link; - next_w = w->link; - - // and put it on the new weak ptr list. - // NB. we must retain the order of the weak_ptr_list (#7160) - if (weak_ptr_list == NULL) { - weak_ptr_list = w; - } else { - weak_ptr_list_tail->link = w; - } - weak_ptr_list_tail = w; - w->link = NULL; - flag = rtsTrue; - - debugTrace(DEBUG_weak, - "weak pointer still alive at %p -> %p", - w, w->key); - continue; - } - else { - last_w = &(w->link); - next_w = w->link; - continue; - } - - default: - barf("traverseWeakPtrList: not WEAK"); - } - } - - /* If we didn't make any changes, then we can go round and kill all - * the dead weak pointers. The old_weak_ptr list is used as a list - * of pending finalizers later on. - */ - if (flag == rtsFalse) { - for (w = old_weak_ptr_list; w; w = w->link) { - evacuate(&w->finalizer); - } - - // Next, move to the WeakThreads stage after fully - // scavenging the finalizers we've just evacuated. - weak_stage = WeakThreads; - } - - return rtsTrue; - case WeakThreads: - /* Now deal with the step->threads lists, which behave somewhat like + /* Now deal with the gen->threads lists, which behave somewhat like * the weak ptr list. If we discover any threads that are about to * become garbage, we wake them up and administer an exception. */ { nat g; - // Traverse thread lists for generations we collected... -// ToDo when we have one gen per capability: -// for (n = 0; n < n_capabilities; n++) { -// if (tidyThreadList(&nurseries[n])) { -// flag = rtsTrue; -// } -// } for (g = 0; g <= N; g++) { - if (tidyThreadList(&generations[g])) { + tidyThreadList(&generations[g]); + } + + // Use weak pointer relationships (value is reachable if + // key is reachable): + for (g = 0; g <= N; g++) { + if (tidyWeakList(&generations[g])) { flag = rtsTrue; } } + + // if we evacuated anything new, we must scavenge thoroughly + // before we can determine which threads are unreachable. + if (flag) return rtsTrue; - /* If we evacuated any threads, we need to go back to the scavenger. - */ + // Resurrect any threads which were unreachable + for (g = 0; g <= N; g++) { + if (resurrectUnreachableThreads(&generations[g])) { + flag = rtsTrue; + } + } + + // Next, move to the WeakPtrs stage after fully + // scavenging the finalizers we've just evacuated. + weak_stage = WeakPtrs; + + // if we evacuated anything new, we must scavenge thoroughly + // before entering the WeakPtrs stage. if (flag) return rtsTrue; - /* And resurrect any threads which were about to become garbage. + // otherwise, fall through... + } + + case WeakPtrs: + { + nat g; + + // resurrecting threads might have made more weak pointers + // alive, so traverse those lists again: + for (g = 0; g <= N; g++) { + if (tidyWeakList(&generations[g])) { + flag = rtsTrue; + } + } + + /* If we didn't make any changes, then we can go round and kill all + * the dead weak pointers. The dead_weak_ptr list is used as a list + * of pending finalizers later on. */ - { - nat g; + if (flag == rtsFalse) { for (g = 0; g <= N; g++) { - resurrectUnreachableThreads(&generations[g]); + collectDeadWeakPtrs(&generations[g]); } + + weak_stage = WeakDone; // *now* we're done, } - - weak_stage = WeakDone; // *now* we're done, + return rtsTrue; // but one more round of scavenging, please } - + default: barf("traverse_weak_ptr_list"); return rtsTrue; } } - static void resurrectUnreachableThreads (generation *gen) +static void collectDeadWeakPtrs (generation *gen) +{ + StgWeak *w, *next_w; + for (w = gen->old_weak_ptr_list; w != NULL; w = next_w) { + evacuate(&w->finalizer); + next_w = w->link; + w->link = dead_weak_ptr_list; + dead_weak_ptr_list = w; + } +} + +static rtsBool resurrectUnreachableThreads (generation *gen) { StgTSO *t, *tmp, *next; + rtsBool flag = rtsFalse; for (t = gen->old_threads; t != END_TSO_QUEUE; t = next) { next = t->global_link; @@ -250,14 +219,89 @@ traverseWeakPtrList(void) evacuate((StgClosure **)&tmp); tmp->global_link = resurrected_threads; resurrected_threads = tmp; + flag = rtsTrue; } } + return flag; } -static rtsBool tidyThreadList (generation *gen) +static rtsBool tidyWeakList(generation *gen) { - StgTSO *t, *tmp, *next, **prev; + StgWeak *w, **last_w, *next_w; + const StgInfoTable *info; + StgClosure *new; rtsBool flag = rtsFalse; + last_w = &gen->old_weak_ptr_list; + for (w = gen->old_weak_ptr_list; w != NULL; w = next_w) { + + /* There might be a DEAD_WEAK on the list if finalizeWeak# was + * called on a live weak pointer object. Just remove it. + */ + if (w->header.info == &stg_DEAD_WEAK_info) { + next_w = w->link; + *last_w = next_w; + continue; + } + + info = get_itbl((StgClosure *)w); + switch (info->type) { + + case WEAK: + /* Now, check whether the key is reachable. + */ + new = isAlive(w->key); + if (new != NULL) { + generation *new_gen; + + w->key = new; + + // Find out which generation this weak ptr is in, and + // move it onto the weak ptr list of that generation. + + new_gen = Bdescr((P_)w)->gen; + gct->evac_gen_no = new_gen->no; + + // evacuate the value and finalizer + evacuate(&w->value); + evacuate(&w->finalizer); + // remove this weak ptr from the old_weak_ptr list + *last_w = w->link; + next_w = w->link; + + // and put it on the correct weak ptr list. + w->link = new_gen->weak_ptr_list; + new_gen->weak_ptr_list = w; + flag = rtsTrue; + + if (gen->no != new_gen->no) { + debugTrace(DEBUG_weak, + "moving weak pointer %p from %d to %d", + w, gen->no, new_gen->no); + } + + + debugTrace(DEBUG_weak, + "weak pointer still alive at %p -> %p", + w, w->key); + continue; + } + else { + last_w = &(w->link); + next_w = w->link; + continue; + } + + default: + barf("tidyWeakList: not WEAK: %d, %p", info->type, w); + } + } + + return flag; +} + +static void tidyThreadList (generation *gen) +{ + StgTSO *t, *tmp, *next, **prev; prev = &gen->old_threads; @@ -297,45 +341,45 @@ static rtsBool tidyThreadList (generation *gen) new_gen->threads = t; } } - - return flag; } /* ----------------------------------------------------------------------------- Evacuate every weak pointer object on the weak_ptr_list, and update the link fields. - - ToDo: with a lot of weak pointers, this will be expensive. We - should have a per-GC weak pointer list, just like threads. -------------------------------------------------------------------------- */ void markWeakPtrList ( void ) { - StgWeak *w, **last_w; + nat g; + + for (g = 0; g <= N; g++) { + generation *gen = &generations[g]; + StgWeak *w, **last_w; - last_w = &weak_ptr_list; - for (w = weak_ptr_list; w; w = w->link) { - // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here + last_w = &gen->weak_ptr_list; + for (w = gen->weak_ptr_list; w != NULL; w = w->link) { + // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here #ifdef DEBUG - { // careful to do this assertion only reading the info ptr - // once, because during parallel GC it might change under our feet. - const StgInfoTable *info; - info = w->header.info; - ASSERT(IS_FORWARDING_PTR(info) - || info == &stg_DEAD_WEAK_info - || INFO_PTR_TO_STRUCT(info)->type == WEAK); - } + { // careful to do this assertion only reading the info ptr + // once, because during parallel GC it might change under our feet. + const StgInfoTable *info; + info = w->header.info; + ASSERT(IS_FORWARDING_PTR(info) + || info == &stg_DEAD_WEAK_info + || INFO_PTR_TO_STRUCT(info)->type == WEAK); + } #endif - evacuate((StgClosure **)last_w); - w = *last_w; - if (w->header.info == &stg_DEAD_WEAK_info) { - last_w = &(((StgDeadWeak*)w)->link); - } else { - last_w = &(w->link); - } - } + evacuate((StgClosure **)last_w); + w = *last_w; + if (w->header.info == &stg_DEAD_WEAK_info) { + last_w = &(w->link); + } else { + last_w = &(w->link); + } + } + } } diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index f0e1659e12..9b579abbbc 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -519,6 +519,7 @@ checkTSO(StgTSO *tso) info == &stg_WHITEHOLE_info); // happens due to STM doing lockTSO() if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo || tso->why_blocked == NotBlocked diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 6137f6d862..e0cc688b95 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -71,6 +71,7 @@ scavengeTSO (StgTSO *tso) evacuate((StgClosure **)&tso->_link); if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo || tso->why_blocked == NotBlocked diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 5c4e54f98d..a5337bc5b2 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -29,6 +29,9 @@ #include "Trace.h" #include "GC.h" #include "Evac.h" +#if defined(ios_HOST_OS) +#include "Hash.h" +#endif #include <string.h> @@ -90,6 +93,8 @@ initGeneration (generation *gen, int g) #endif gen->threads = END_TSO_QUEUE; gen->old_threads = END_TSO_QUEUE; + gen->weak_ptr_list = NULL; + gen->old_weak_ptr_list = NULL; } void @@ -166,7 +171,6 @@ initStorage (void) generations[0].max_blocks = 0; - weak_ptr_list = NULL; caf_list = END_OF_STATIC_LIST; revertible_caf_list = END_OF_STATIC_LIST; @@ -1094,7 +1098,7 @@ calcNeeded (rtsBool force_major, memcount *blocks_needed) // because it knows how to work around the restrictions put in place // by SELinux. -void *allocateExec (W_ bytes, void **exec_ret) +AdjustorWritable allocateExec (W_ bytes, AdjustorExecutable *exec_ret) { void **ret, **exec; ACQUIRE_SM_LOCK; @@ -1107,18 +1111,65 @@ void *allocateExec (W_ bytes, void **exec_ret) } // freeExec gets passed the executable address, not the writable address. -void freeExec (void *addr) +void freeExec (AdjustorExecutable addr) { - void *writable; + AdjustorWritable writable; writable = *((void**)addr - 1); ACQUIRE_SM_LOCK; ffi_closure_free (writable); RELEASE_SM_LOCK } +#elif defined(ios_HOST_OS) + +static HashTable* allocatedExecs; + +AdjustorWritable allocateExec(W_ bytes, AdjustorExecutable *exec_ret) +{ + AdjustorWritable writ; + ffi_closure* cl; + if (bytes != sizeof(ffi_closure)) { + barf("allocateExec: for ffi_closure only"); + } + ACQUIRE_SM_LOCK; + cl = writ = ffi_closure_alloc((size_t)bytes, exec_ret); + if (cl != NULL) { + if (allocatedExecs == NULL) { + allocatedExecs = allocHashTable(); + } + insertHashTable(allocatedExecs, (StgWord)*exec_ret, writ); + } + RELEASE_SM_LOCK; + return writ; +} + +AdjustorWritable execToWritable(AdjustorExecutable exec) +{ + AdjustorWritable writ; + ACQUIRE_SM_LOCK; + if (allocatedExecs == NULL || + (writ = lookupHashTable(allocatedExecs, (StgWord)exec)) == NULL) { + RELEASE_SM_LOCK; + barf("execToWritable: not found"); + } + RELEASE_SM_LOCK; + return writ; +} + +void freeExec(AdjustorExecutable exec) +{ + AdjustorWritable writ; + ffi_closure* cl; + cl = writ = execToWritable(exec); + ACQUIRE_SM_LOCK; + removeHashTable(allocatedExecs, (StgWord)exec, writ); + ffi_closure_free(cl); + RELEASE_SM_LOCK +} + #else -void *allocateExec (W_ bytes, void **exec_ret) +AdjustorWritable allocateExec (W_ bytes, AdjustorExecutable *exec_ret) { void *ret; W_ n; |