[Git][ghc/ghc][wip/stack_cloning] Add printStack
Sven Tennie
gitlab at gitlab.haskell.org
Sun Oct 11 17:49:56 UTC 2020
Sven Tennie pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC
Commits:
14599b01 by Sven Tennie at 2020-10-11T19:49:36+02:00
Add printStack
- - - - -
6 changed files:
- + includes/rts/PrinterAPI.h
- libraries/base/GHC/Stack/CloneStack.hs
- rts/Disassembler.c
- rts/Disassembler.h
- rts/Printer.c
- rts/Printer.h
Changes:
=====================================
includes/rts/PrinterAPI.h
=====================================
@@ -0,0 +1,3 @@
+#pragma once
+
+extern void printStack (StgStack* stack);
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -8,6 +8,7 @@
module GHC.Stack.CloneStack (
cloneThreadStack,
cloneMyStack,
+ printStack,
StackSnapshot(..)
) where
@@ -19,6 +20,8 @@ import GHC.IO (IO(..))
foreign import ccall "sendCloneStackMessage" sendCloneStackMessage :: ThreadId# -> StablePtr PrimMVar -> IO ()
+foreign import ccall "PrinterAPI.h printStack" printStack_c :: StackSnapshot# -> IO ()
+
data StackSnapshot = StackSnapshot StackSnapshot#
{- Note [Stack Cloning]
@@ -50,3 +53,7 @@ cloneThreadStack (ThreadId tid#) = do
cloneMyStack :: IO StackSnapshot
cloneMyStack = IO $ \s ->
case (cloneMyStack# s) of (# s1, stack #) -> (# s1, StackSnapshot stack #)
+
+-- | Print the stack
+printStack :: StackSnapshot -> IO ()
+printStack (StackSnapshot stack) = printStack_c stack
=====================================
rts/Disassembler.c
=====================================
@@ -8,8 +8,6 @@
* $Date: 2004/09/03 15:28:19 $
* ---------------------------------------------------------------------------*/
-#if defined(DEBUG)
-
#include "PosixSource.h"
#include "Rts.h"
#include "RtsAPI.h"
@@ -358,5 +356,3 @@ void disassemble( StgBCO *bco )
debugBelch("\n");
}
-
-#endif /* DEBUG */
=====================================
rts/Disassembler.h
=====================================
@@ -8,9 +8,5 @@
#pragma once
-#if defined(DEBUG)
-
RTS_PRIVATE int disInstr ( StgBCO *bco, int pc );
RTS_PRIVATE void disassemble( StgBCO *bco );
-
-#endif
=====================================
rts/Printer.c
=====================================
@@ -25,9 +25,10 @@
#include <string.h>
+#include "Disassembler.h"
+
#if defined(DEBUG)
-#include "Disassembler.h"
#include "Apply.h"
/* --------------------------------------------------------------------------
@@ -58,402 +59,337 @@ void printObj( StgClosure *obj )
printClosure(obj);
}
-STATIC_INLINE void
-printStdObjHdr( const StgClosure *obj, char* tag )
+void
+printMutableList(bdescr *bd)
{
- debugBelch("%s(",tag);
- printPtr((StgPtr)obj->header.info);
-#if defined(PROFILING)
- debugBelch(", %s", obj->header.prof.ccs->cc->label);
-#endif
-}
+ StgPtr p;
-static void
-printStdObjPayload( const StgClosure *obj )
-{
- StgWord i, j;
- const StgInfoTable* info;
+ debugBelch("mutable list %p: ", bd);
- info = get_itbl(obj);
- for (i = 0; i < info->layout.payload.ptrs; ++i) {
- debugBelch(", ");
- printPtr((StgPtr)obj->payload[i]);
- }
- for (j = 0; j < info->layout.payload.nptrs; ++j) {
- debugBelch(", %pd#",obj->payload[i+j]);
+ for (; bd != NULL; bd = bd->link) {
+ for (p = bd->start; p < bd->free; p++) {
+ debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
+ }
}
- debugBelch(")\n");
+ debugBelch("\n");
}
-static void
-printThunkPayload( StgThunk *obj )
+void printTSO( StgTSO *tso )
{
- StgWord i, j;
- const StgInfoTable* info;
-
- info = get_itbl((StgClosure *)obj);
- for (i = 0; i < info->layout.payload.ptrs; ++i) {
- debugBelch(", ");
- printPtr((StgPtr)obj->payload[i]);
- }
- for (j = 0; j < info->layout.payload.nptrs; ++j) {
- debugBelch(", %pd#",obj->payload[i+j]);
- }
- debugBelch(")\n");
+ printStack( tso->stackobj );
}
-static void
-printThunkObject( StgThunk *obj, char* tag )
+void printStaticObjects( StgClosure *p )
{
- printStdObjHdr( (StgClosure *)obj, tag );
- printThunkPayload( obj );
+ while (p != END_OF_STATIC_OBJECT_LIST) {
+ p = UNTAG_STATIC_LIST_PTR(p);
+ printClosure(p);
+
+ const StgInfoTable *info = get_itbl(p);
+ p = *STATIC_LINK(info, p);
+ }
}
-void
-printClosure( const StgClosure *obj )
+void printWeakLists()
{
- debugBelch("%p: ", obj);
- obj = UNTAG_CONST_CLOSURE(obj);
- const StgInfoTable* info = get_itbl(obj);
+ debugBelch("======= WEAK LISTS =======\n");
- while (IS_FORWARDING_PTR(info)) {
- obj = (StgClosure*)UN_FORWARDING_PTR(info);
- debugBelch("(forwarding to %p) ", (void*)obj);
- info = get_itbl(obj);
+ for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
+ debugBelch("Capability %d:\n", cap_idx);
+ Capability *cap = capabilities[cap_idx];
+ for (StgWeak *weak = cap->weak_ptr_list_hd; weak; weak = weak->link) {
+ printClosure((StgClosure*)weak);
+ }
}
- switch ( info->type ) {
- case INVALID_OBJECT:
- barf("Invalid object");
-
- case CONSTR:
- case CONSTR_1_0: case CONSTR_0_1:
- case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
- case CONSTR_NOCAF:
- {
- StgWord i, j;
- const StgConInfoTable *con_info = get_con_itbl (obj);
-
- debugBelch("%s(", GET_CON_DESC(con_info));
- for (i = 0; i < info->layout.payload.ptrs; ++i) {
- if (i != 0) debugBelch(", ");
- printPtr((StgPtr)obj->payload[i]);
- }
- for (j = 0; j < info->layout.payload.nptrs; ++j) {
- if (i != 0 || j != 0) debugBelch(", ");
- debugBelch("%p#", obj->payload[i+j]);
- }
- debugBelch(")\n");
- break;
+ for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
+ generation *gen = &generations[gen_idx];
+ debugBelch("Generation %d current weaks:\n", gen_idx);
+ for (StgWeak *weak = gen->weak_ptr_list; weak; weak = weak->link) {
+ printClosure((StgClosure*)weak);
}
+ debugBelch("Generation %d old weaks:\n", gen_idx);
+ for (StgWeak *weak = gen->old_weak_ptr_list; weak; weak = weak->link) {
+ printClosure((StgClosure*)weak);
+ }
+ }
- case FUN:
- case FUN_1_0: case FUN_0_1:
- case FUN_1_1: case FUN_0_2: case FUN_2_0:
- case FUN_STATIC:
- debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
- printPtr((StgPtr)obj->header.info);
-#if defined(PROFILING)
- debugBelch(", %s", obj->header.prof.ccs->cc->label);
-#endif
- printStdObjPayload(obj);
- break;
-
- case PRIM:
- debugBelch("PRIM(");
- printPtr((StgPtr)obj->header.info);
- printStdObjPayload(obj);
- break;
-
- case MUT_PRIM:
- debugBelch("MUT_PRIM(");
- printPtr((StgPtr)obj->header.info);
- printStdObjPayload(obj);
- break;
-
- case THUNK:
- case THUNK_1_0: case THUNK_0_1:
- case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
- case THUNK_STATIC:
- /* ToDo: will this work for THUNK_STATIC too? */
-#if defined(PROFILING)
- printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
-#else
- printThunkObject((StgThunk *)obj,"THUNK");
-#endif
- break;
+ debugBelch("=========================\n");
+}
- case THUNK_SELECTOR:
- printStdObjHdr(obj, "THUNK_SELECTOR");
- debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
- break;
+void printLargeAndPinnedObjects()
+{
+ debugBelch("====== PINNED OBJECTS ======\n");
- case BCO:
- disassemble( (StgBCO*)obj );
- break;
+ for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
+ Capability *cap = capabilities[cap_idx];
- case AP:
- {
- StgAP* ap = (StgAP*)obj;
- StgWord i;
- debugBelch("AP("); printPtr((StgPtr)ap->fun);
- for (i = 0; i < ap->n_args; ++i) {
- debugBelch(", ");
- printPtr((P_)ap->payload[i]);
- }
- debugBelch(")\n");
- break;
+ debugBelch("Capability %d: Current pinned object block: %p\n",
+ cap_idx, (void*)cap->pinned_object_block);
+ for (bdescr *bd = cap->pinned_object_blocks; bd; bd = bd->link) {
+ debugBelch("%p\n", (void*)bd);
}
+ }
- case PAP:
- {
- StgPAP* pap = (StgPAP*)obj;
- StgWord i;
- debugBelch("PAP/%d(",(int)pap->arity);
- printPtr((StgPtr)pap->fun);
- for (i = 0; i < pap->n_args; ++i) {
- debugBelch(", ");
- printPtr((StgPtr)pap->payload[i]);
- }
- debugBelch(")\n");
- break;
+ debugBelch("====== LARGE OBJECTS =======\n");
+ for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
+ generation *gen = &generations[gen_idx];
+ debugBelch("Generation %d current large objects:\n", gen_idx);
+ for (bdescr *bd = gen->large_objects; bd; bd = bd->link) {
+ debugBelch("%p: ", (void*)bd);
+ printClosure((StgClosure*)bd->start);
}
- case AP_STACK:
- {
- StgAP_STACK* ap = (StgAP_STACK*)obj;
- StgWord i;
- debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
- for (i = 0; i < ap->size; ++i) {
- debugBelch(", ");
- printPtr((P_)ap->payload[i]);
- }
- debugBelch(")\n");
- break;
+ debugBelch("Generation %d scavenged large objects:\n", gen_idx);
+ for (bdescr *bd = gen->scavenged_large_objects; bd; bd = bd->link) {
+ debugBelch("%p: ", (void*)bd);
+ printClosure((StgClosure*)bd->start);
}
+ }
- case IND:
- debugBelch("IND(");
- printPtr((StgPtr)((StgInd*)obj)->indirectee);
- debugBelch(")\n");
- break;
-
- case IND_STATIC:
- debugBelch("IND_STATIC(");
- printPtr((StgPtr)((StgInd*)obj)->indirectee);
- debugBelch(")\n");
- break;
+ debugBelch("============================\n");
+}
- case BLACKHOLE:
- debugBelch("BLACKHOLE(");
- printPtr((StgPtr)((StgInd*)obj)->indirectee);
- debugBelch(")\n");
- break;
+/* --------------------------------------------------------------------------
+ * Address printing code
+ *
+ * Uses symbol table in (unstripped executable)
+ * ------------------------------------------------------------------------*/
- /* Cannot happen -- use default case.
- case RET_BCO:
- case RET_SMALL:
- case RET_BIG:
- case RET_FUN:
- */
+/* --------------------------------------------------------------------------
+ * Simple lookup table
+ * address -> function name
+ * ------------------------------------------------------------------------*/
- case UPDATE_FRAME:
- {
- StgUpdateFrame* u = (StgUpdateFrame*)obj;
- debugBelch("%s(", info_update_frame(obj));
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
- debugBelch(",");
- printPtr((StgPtr)u->updatee);
- debugBelch(")\n");
- break;
- }
+static HashTable * add_to_fname_table = NULL;
- case CATCH_FRAME:
- {
- StgCatchFrame* u = (StgCatchFrame*)obj;
- debugBelch("CATCH_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
- debugBelch(",");
- printPtr((StgPtr)u->handler);
- debugBelch(")\n");
- break;
- }
-
- case UNDERFLOW_FRAME:
- {
- StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
- debugBelch("UNDERFLOW_FRAME(");
- printPtr((StgPtr)u->next_chunk);
- debugBelch(")\n");
- break;
- }
-
- case STOP_FRAME:
- {
- StgStopFrame* u = (StgStopFrame*)obj;
- debugBelch("STOP_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
- debugBelch(")\n");
- break;
- }
-
- case ARR_WORDS:
- {
- StgWord i;
- debugBelch("ARR_WORDS(\"");
- for (i=0; i<arr_words_words((StgArrBytes *)obj); i++)
- debugBelch("%" FMT_Word, (W_)((StgArrBytes *)obj)->payload[i]);
- debugBelch("\")\n");
- break;
- }
-
- case MUT_ARR_PTRS_CLEAN:
- debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
- break;
-
- case MUT_ARR_PTRS_DIRTY:
- debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
- break;
+const char *lookupGHCName( void *addr )
+{
+ if (add_to_fname_table == NULL)
+ return NULL;
- case MUT_ARR_PTRS_FROZEN_CLEAN:
- debugBelch("MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
- break;
+ return lookupHashTable(add_to_fname_table, (StgWord)addr);
+}
- case SMALL_MUT_ARR_PTRS_CLEAN:
- debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
- (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
- break;
+/* --------------------------------------------------------------------------
+ * Symbol table loading
+ * ------------------------------------------------------------------------*/
- case SMALL_MUT_ARR_PTRS_DIRTY:
- debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
- (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
- break;
+/* Causing linking trouble on Win32 plats, so I'm
+ disabling this for now.
+*/
+#if defined(USING_LIBBFD)
+# define PACKAGE 1
+# define PACKAGE_VERSION 1
+/* Those PACKAGE_* defines are workarounds for bfd:
+ * https://sourceware.org/bugzilla/show_bug.cgi?id=14243
+ * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
+ * with user's autoconf-based Cabal packages.
+ * It's a shame <bfd.h> checks for unrelated fields instead of actually used
+ * macros.
+ */
+# include <bfd.h>
- case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
- debugBelch("SMALL_MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n",
- (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
- break;
+/* Fairly ad-hoc piece of code that seems to filter out a lot of
+ * rubbish like the obj-splitting symbols
+ */
- case MVAR_CLEAN:
- case MVAR_DIRTY:
- {
- StgMVar* mv = (StgMVar*)obj;
+static bool isReal( flagword flags STG_UNUSED, const char *name )
+{
+#if 0
+ /* ToDo: make this work on BFD */
+ int tp = type & N_TYPE;
+ if (tp == N_TEXT || tp == N_DATA) {
+ return (name[0] == '_' && name[1] != '_');
+ } else {
+ return false;
+ }
+#else
+ if (*name == '\0' ||
+ (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
+ (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
+ return false;
+ }
+ return true;
+#endif
+}
- debugBelch("MVAR(head=");
- if ((StgClosure*)mv->head == &stg_END_TSO_QUEUE_closure) {
- debugBelch("END_TSO_QUEUE");
- } else {
- debugBelch("%p", mv->head);
- }
+extern void DEBUG_LoadSymbols( const char *name )
+{
+ bfd* abfd;
+ char **matching;
- debugBelch(", tail=");
- if ((StgClosure*)mv->tail == &stg_END_TSO_QUEUE_closure) {
- debugBelch("END_TSO_QUEUE");
- } else {
- debugBelch("%p", mv->tail);
- }
+ bfd_init();
+ abfd = bfd_openr(name, "default");
+ if (abfd == NULL) {
+ barf("can't open executable %s to get symbol table", name);
+ }
+ if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
+ barf("mismatch");
+ }
- debugBelch(", value=");
- if ((StgClosure*)mv->value == &stg_END_TSO_QUEUE_closure) {
- debugBelch("END_TSO_QUEUE");
- } else {
- debugBelch("%p", mv->value);
- }
- debugBelch(")\n");
+ {
+ long storage_needed;
+ asymbol **symbol_table;
+ long number_of_symbols;
+ long num_real_syms = 0;
+ long i;
- break;
- }
+ storage_needed = bfd_get_symtab_upper_bound (abfd);
- case TVAR:
- {
- StgTVar* tv = (StgTVar*)obj;
- debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
- break;
+ if (storage_needed < 0) {
+ barf("can't read symbol table");
}
+ symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
- case MUT_VAR_CLEAN:
- {
- StgMutVar* mv = (StgMutVar*)obj;
- debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
- break;
- }
+ number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
- case MUT_VAR_DIRTY:
- {
- StgMutVar* mv = (StgMutVar*)obj;
- debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
- break;
+ if (number_of_symbols < 0) {
+ barf("can't canonicalise symbol table");
}
- case WEAK:
- debugBelch("WEAK(");
- debugBelch("key=%p value=%p finalizer=%p",
- (StgPtr)(((StgWeak*)obj)->key),
- (StgPtr)(((StgWeak*)obj)->value),
- (StgPtr)(((StgWeak*)obj)->finalizer));
- debugBelch(")\n");
- /* ToDo: chase 'link' ? */
- break;
-
- case TSO:
- debugBelch("TSO(");
- debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
- debugBelch(")\n");
- break;
-
- case STACK:
- debugBelch("STACK\n");
- break;
-
-#if 0
- /* Symptomatic of a problem elsewhere, have it fall-through & fail */
- case EVACUATED:
- debugBelch("EVACUATED(");
- printClosure((StgEvacuated*)obj->evacuee);
- debugBelch(")\n");
- break;
-#endif
+ if (add_to_fname_table == NULL)
+ add_to_fname_table = allocHashTable();
- case COMPACT_NFDATA:
- debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n",
- (W_)((StgCompactNFData *)obj)->totalW * (W_)sizeof(W_));
- break;
+ for( i = 0; i != number_of_symbols; ++i ) {
+ symbol_info info;
+ bfd_get_symbol_info(abfd,symbol_table[i],&info);
+ if (isReal(info.type, info.name)) {
+ insertHashTable(add_to_fname_table,
+ info.value, (void*)info.name);
+ num_real_syms += 1;
+ }
+ }
- case TREC_CHUNK:
- debugBelch("TREC_CHUNK\n");
- break;
+ IF_DEBUG(interpreter,
+ debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
+ number_of_symbols, num_real_syms)
+ );
- default:
- //barf("printClosure %d",get_itbl(obj)->type);
- debugBelch("*** printClosure: unknown type %d ****\n",
- (int)get_itbl(obj)->type );
- barf("printClosure %d",get_itbl(obj)->type);
- return;
+ stgFree(symbol_table);
}
}
-void
-printMutableList(bdescr *bd)
+#else /* USING_LIBBFD */
+
+extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
{
- StgPtr p;
+ /* nothing, yet */
+}
- debugBelch("mutable list %p: ", bd);
+#endif /* USING_LIBBFD */
- for (; bd != NULL; bd = bd->link) {
- for (p = bd->start; p < bd->free; p++) {
- debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p));
- }
- }
- debugBelch("\n");
-}
+void findPtr(P_ p, int); /* keep gcc -Wall happy */
-// If you know you have an UPDATE_FRAME, but want to know exactly which.
-const char *info_update_frame(const StgClosure *closure)
+int searched = 0;
+
+static int
+findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
{
- // Note: We intentionally don't take the info table pointer as
- // an argument. As it will be confusing whether one should pass
- // it pointing to the code or struct members when compiling with
- // TABLES_NEXT_TO_CODE.
+ StgPtr q, r, end;
+ for (; bd; bd = bd->link) {
+ searched++;
+ for (q = bd->start; q < bd->free; q++) {
+ if (UNTAG_CONST_CLOSURE((StgClosure*)*q) == (const StgClosure *)p) {
+ if (i < arr_size) {
+ for (r = bd->start; r < bd->free; r = end) {
+ // skip over zeroed-out slop
+ while (*r == 0) r++;
+ if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
+ debugBelch("%p found at %p, no closure at %p\n",
+ p, q, r);
+ break;
+ }
+ end = r + closure_sizeW((StgClosure*)r);
+ if (q < end) {
+ debugBelch("%p = ", r);
+ printClosure((StgClosure *)r);
+ arr[i++] = r;
+ break;
+ }
+ }
+ if (r >= bd->free) {
+ debugBelch("%p found at %p, closure?", p, q);
+ }
+ } else {
+ return i;
+ }
+ }
+ }
+ }
+ return i;
+}
+
+void
+findPtr(P_ p, int follow)
+{
+ uint32_t g, n;
+ bdescr *bd;
+ const int arr_size = 1024;
+ StgPtr arr[arr_size];
+ int i = 0;
+ searched = 0;
+
+#if 0
+ // We can't search the nursery, because we don't know which blocks contain
+ // valid data, because the bd->free pointers in the nursery are only reset
+ // just before a block is used.
+ for (n = 0; n < n_capabilities; n++) {
+ bd = nurseries[i].blocks;
+ i = findPtrBlocks(p,bd,arr,arr_size,i);
+ if (i >= arr_size) return;
+ }
+#endif
+
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ bd = generations[g].blocks;
+ i = findPtrBlocks(p,bd,arr,arr_size,i);
+ bd = generations[g].large_objects;
+ i = findPtrBlocks(p,bd,arr,arr_size,i);
+ if (i >= arr_size) return;
+ for (n = 0; n < n_capabilities; n++) {
+ i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
+ arr, arr_size, i);
+ i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
+ arr, arr_size, i);
+ }
+ if (i >= arr_size) return;
+ }
+ if (follow && i == 1) {
+ debugBelch("-->\n");
+ findPtr(arr[0], 1);
+ }
+}
+
+const char *what_next_strs[] = {
+ [0] = "(unknown)",
+ [ThreadRunGHC] = "ThreadRunGHC",
+ [ThreadInterpret] = "ThreadInterpret",
+ [ThreadKilled] = "ThreadKilled",
+ [ThreadComplete] = "ThreadComplete"
+};
+
+#else /* DEBUG */
+void printPtr( StgPtr p )
+{
+ debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
+}
+
+void printObj( StgClosure *obj )
+{
+ debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
+}
+
+
+#endif /* DEBUG */
+
+// If you know you have an UPDATE_FRAME, but want to know exactly which.
+const char *info_update_frame(const StgClosure *closure)
+{
+ // Note: We intentionally don't take the info table pointer as
+ // an argument. As it will be confusing whether one should pass
+ // it pointing to the code or struct members when compiling with
+ // TABLES_NEXT_TO_CODE.
const StgInfoTable *info = closure->header.info;
if (info == &stg_upd_frame_info) {
return "NORMAL_UPDATE_FRAME";
@@ -467,496 +403,561 @@ const char *info_update_frame(const StgClosure *closure)
}
static void
-printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
- uint32_t size )
+printThunkPayload( StgThunk *obj )
{
- uint32_t i;
+ StgWord i, j;
+ const StgInfoTable* info;
- for(i = 0; i < size; i++, bitmap >>= 1 ) {
- debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
- if ((bitmap & 1) == 0) {
- printPtr((P_)payload[i]);
- debugBelch("\n");
- } else {
- debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
- }
+ info = get_itbl((StgClosure *)obj);
+ for (i = 0; i < info->layout.payload.ptrs; ++i) {
+ debugBelch(", ");
+ printPtr((StgPtr)obj->payload[i]);
+ }
+ for (j = 0; j < info->layout.payload.nptrs; ++j) {
+ debugBelch(", %pd#",obj->payload[i+j]);
}
+ debugBelch(")\n");
+}
+
+STATIC_INLINE void
+printStdObjHdr( const StgClosure *obj, char* tag )
+{
+ debugBelch("%s(",tag);
+ printPtr((StgPtr)obj->header.info);
+#if defined(PROFILING)
+ debugBelch(", %s", obj->header.prof.ccs->cc->label);
+#endif
}
static void
-printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
- uint32_t size )
+printThunkObject( StgThunk *obj, char* tag )
{
- StgWord bmp;
- uint32_t i, j;
+ printStdObjHdr( (StgClosure *)obj, tag );
+ printThunkPayload( obj );
+}
- i = 0;
- for (bmp=0; i < size; bmp++) {
- StgWord bitmap = large_bitmap->bitmap[bmp];
- j = 0;
- for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
- debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
- if ((bitmap & 1) == 0) {
- printPtr((P_)payload[i]);
- debugBelch("\n");
- } else {
- debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
- }
- }
+static void
+printStdObjPayload( const StgClosure *obj )
+{
+ StgWord i, j;
+ const StgInfoTable* info;
+
+ info = get_itbl(obj);
+ for (i = 0; i < info->layout.payload.ptrs; ++i) {
+ debugBelch(", ");
+ printPtr((StgPtr)obj->payload[i]);
+ }
+ for (j = 0; j < info->layout.payload.nptrs; ++j) {
+ debugBelch(", %pd#",obj->payload[i+j]);
}
+ debugBelch(")\n");
}
void
-printStackChunk( StgPtr sp, StgPtr spBottom )
+printClosure( const StgClosure *obj )
{
- StgWord bitmap;
- const StgInfoTable *info;
+ debugBelch("%p: ", obj);
+ obj = UNTAG_CONST_CLOSURE(obj);
+ const StgInfoTable* info = get_itbl(obj);
- ASSERT(sp <= spBottom);
- for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
+ while (IS_FORWARDING_PTR(info)) {
+ obj = (StgClosure*)UN_FORWARDING_PTR(info);
+ debugBelch("(forwarding to %p) ", (void*)obj);
+ info = get_itbl(obj);
+ }
- info = get_itbl((StgClosure *)sp);
+ switch ( info->type ) {
+ case INVALID_OBJECT:
+ barf("Invalid object");
- switch (info->type) {
+ case CONSTR:
+ case CONSTR_1_0: case CONSTR_0_1:
+ case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0:
+ case CONSTR_NOCAF:
+ {
+ StgWord i, j;
+ const StgConInfoTable *con_info = get_con_itbl (obj);
- case UPDATE_FRAME:
- case CATCH_FRAME:
- case UNDERFLOW_FRAME:
- case STOP_FRAME:
- printClosure((StgClosure*)sp);
- continue;
+ debugBelch("%s(", GET_CON_DESC(con_info));
+ for (i = 0; i < info->layout.payload.ptrs; ++i) {
+ if (i != 0) debugBelch(", ");
+ printPtr((StgPtr)obj->payload[i]);
+ }
+ for (j = 0; j < info->layout.payload.nptrs; ++j) {
+ if (i != 0 || j != 0) debugBelch(", ");
+ debugBelch("%p#", obj->payload[i+j]);
+ }
+ debugBelch(")\n");
+ break;
+ }
- case RET_SMALL: {
- StgWord c = *sp;
- if (c == (StgWord)&stg_ctoi_R1p_info) {
- debugBelch("tstg_ctoi_ret_R1p_info\n" );
- } else if (c == (StgWord)&stg_ctoi_R1n_info) {
- debugBelch("stg_ctoi_ret_R1n_info\n" );
- } else if (c == (StgWord)&stg_ctoi_F1_info) {
- debugBelch("stg_ctoi_ret_F1_info\n" );
- } else if (c == (StgWord)&stg_ctoi_D1_info) {
- debugBelch("stg_ctoi_ret_D1_info\n" );
- } else if (c == (StgWord)&stg_ctoi_V_info) {
- debugBelch("stg_ctoi_ret_V_info\n" );
- } else if (c == (StgWord)&stg_ap_v_info) {
- debugBelch("stg_ap_v_info\n" );
- } else if (c == (StgWord)&stg_ap_f_info) {
- debugBelch("stg_ap_f_info\n" );
- } else if (c == (StgWord)&stg_ap_d_info) {
- debugBelch("stg_ap_d_info\n" );
- } else if (c == (StgWord)&stg_ap_l_info) {
- debugBelch("stg_ap_l_info\n" );
- } else if (c == (StgWord)&stg_ap_n_info) {
- debugBelch("stg_ap_n_info\n" );
- } else if (c == (StgWord)&stg_ap_p_info) {
- debugBelch("stg_ap_p_info\n" );
- } else if (c == (StgWord)&stg_ap_pp_info) {
- debugBelch("stg_ap_pp_info\n" );
- } else if (c == (StgWord)&stg_ap_ppp_info) {
- debugBelch("stg_ap_ppp_info\n" );
- } else if (c == (StgWord)&stg_ap_pppp_info) {
- debugBelch("stg_ap_pppp_info\n" );
- } else if (c == (StgWord)&stg_ap_ppppp_info) {
- debugBelch("stg_ap_ppppp_info\n" );
- } else if (c == (StgWord)&stg_ap_pppppp_info) {
- debugBelch("stg_ap_pppppp_info\n" );
- } else if (c == (StgWord)&stg_ret_v_info) {
- debugBelch("stg_ret_v_info\n" );
- } else if (c == (StgWord)&stg_ret_p_info) {
- debugBelch("stg_ret_p_info\n" );
- } else if (c == (StgWord)&stg_ret_n_info) {
- debugBelch("stg_ret_n_info\n" );
- } else if (c == (StgWord)&stg_ret_f_info) {
- debugBelch("stg_ret_f_info\n" );
- } else if (c == (StgWord)&stg_ret_d_info) {
- debugBelch("stg_ret_d_info\n" );
- } else if (c == (StgWord)&stg_ret_l_info) {
- debugBelch("stg_ret_l_info\n" );
+ case FUN:
+ case FUN_1_0: case FUN_0_1:
+ case FUN_1_1: case FUN_0_2: case FUN_2_0:
+ case FUN_STATIC:
+ debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
+ printPtr((StgPtr)obj->header.info);
#if defined(PROFILING)
- } else if (c == (StgWord)&stg_restore_cccs_info) {
- debugBelch("stg_restore_cccs_info\n" );
- fprintCCS(stderr, (CostCentreStack*)sp[1]);
- debugBelch("\n" );
- continue;
- } else if (c == (StgWord)&stg_restore_cccs_eval_info) {
- debugBelch("stg_restore_cccs_eval_info\n" );
- fprintCCS(stderr, (CostCentreStack*)sp[1]);
- debugBelch("\n" );
- continue;
+ debugBelch(", %s", obj->header.prof.ccs->cc->label);
#endif
- } else {
- debugBelch("RET_SMALL (%p)\n", info);
- }
- bitmap = info->layout.bitmap;
- printSmallBitmap(spBottom, sp+1,
- BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
- continue;
- }
+ printStdObjPayload(obj);
+ break;
- case RET_BCO: {
- StgBCO *bco;
+ case PRIM:
+ debugBelch("PRIM(");
+ printPtr((StgPtr)obj->header.info);
+ printStdObjPayload(obj);
+ break;
- bco = ((StgBCO *)sp[1]);
+ case MUT_PRIM:
+ debugBelch("MUT_PRIM(");
+ printPtr((StgPtr)obj->header.info);
+ printStdObjPayload(obj);
+ break;
- debugBelch("RET_BCO (%p)\n", sp);
- printLargeBitmap(spBottom, sp+2,
- BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
- continue;
- }
+ case THUNK:
+ case THUNK_1_0: case THUNK_0_1:
+ case THUNK_1_1: case THUNK_0_2: case THUNK_2_0:
+ case THUNK_STATIC:
+ /* ToDo: will this work for THUNK_STATIC too? */
+#if defined(PROFILING)
+ printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
+#else
+ printThunkObject((StgThunk *)obj,"THUNK");
+#endif
+ break;
- case RET_BIG:
- barf("todo");
+ case THUNK_SELECTOR:
+ printStdObjHdr(obj, "THUNK_SELECTOR");
+ debugBelch(", %p)\n", ((StgSelector *)obj)->selectee);
+ break;
- case RET_FUN:
+ case BCO:
+ disassemble( (StgBCO*)obj );
+ break;
+
+ case AP:
{
- const StgFunInfoTable *fun_info;
- StgRetFun *ret_fun;
+ StgAP* ap = (StgAP*)obj;
+ StgWord i;
+ debugBelch("AP("); printPtr((StgPtr)ap->fun);
+ for (i = 0; i < ap->n_args; ++i) {
+ debugBelch(", ");
+ printPtr((P_)ap->payload[i]);
+ }
+ debugBelch(")\n");
+ break;
+ }
- ret_fun = (StgRetFun *)sp;
- fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
- debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
- switch (fun_info->f.fun_type) {
- case ARG_GEN:
- printSmallBitmap(spBottom, sp+2,
- BITMAP_BITS(fun_info->f.b.bitmap),
- BITMAP_SIZE(fun_info->f.b.bitmap));
- break;
- case ARG_GEN_BIG:
- printLargeBitmap(spBottom, sp+2,
- GET_FUN_LARGE_BITMAP(fun_info),
- GET_FUN_LARGE_BITMAP(fun_info)->size);
- break;
- default:
- printSmallBitmap(spBottom, sp+2,
- BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
- BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
- break;
+ case PAP:
+ {
+ StgPAP* pap = (StgPAP*)obj;
+ StgWord i;
+ debugBelch("PAP/%d(",(int)pap->arity);
+ printPtr((StgPtr)pap->fun);
+ for (i = 0; i < pap->n_args; ++i) {
+ debugBelch(", ");
+ printPtr((StgPtr)pap->payload[i]);
}
- continue;
+ debugBelch(")\n");
+ break;
}
- default:
- debugBelch("unknown object %d\n", (int)info->type);
- barf("printStackChunk");
+ case AP_STACK:
+ {
+ StgAP_STACK* ap = (StgAP_STACK*)obj;
+ StgWord i;
+ debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
+ for (i = 0; i < ap->size; ++i) {
+ debugBelch(", ");
+ printPtr((P_)ap->payload[i]);
+ }
+ debugBelch(")\n");
+ break;
}
- }
-}
-// TODO: Do not merge. Only exported for debugging.
-void printStack( StgStack *stack )
-{
- printStackChunk( stack->sp, stack->stack + stack->stack_size );
-}
+ case IND:
+ debugBelch("IND(");
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
+ debugBelch(")\n");
+ break;
-void printTSO( StgTSO *tso )
-{
- printStack( tso->stackobj );
-}
+ case IND_STATIC:
+ debugBelch("IND_STATIC(");
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
+ debugBelch(")\n");
+ break;
-void printStaticObjects( StgClosure *p )
-{
- while (p != END_OF_STATIC_OBJECT_LIST) {
- p = UNTAG_STATIC_LIST_PTR(p);
- printClosure(p);
+ case BLACKHOLE:
+ debugBelch("BLACKHOLE(");
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
+ debugBelch(")\n");
+ break;
- const StgInfoTable *info = get_itbl(p);
- p = *STATIC_LINK(info, p);
- }
-}
+ /* Cannot happen -- use default case.
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_BIG:
+ case RET_FUN:
+ */
-void printWeakLists()
-{
- debugBelch("======= WEAK LISTS =======\n");
+ case UPDATE_FRAME:
+ {
+ StgUpdateFrame* u = (StgUpdateFrame*)obj;
+ debugBelch("%s(", info_update_frame(obj));
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->updatee);
+ debugBelch(")\n");
+ break;
+ }
- for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
- debugBelch("Capability %d:\n", cap_idx);
- Capability *cap = capabilities[cap_idx];
- for (StgWeak *weak = cap->weak_ptr_list_hd; weak; weak = weak->link) {
- printClosure((StgClosure*)weak);
+ case CATCH_FRAME:
+ {
+ StgCatchFrame* u = (StgCatchFrame*)obj;
+ debugBelch("CATCH_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->handler);
+ debugBelch(")\n");
+ break;
}
- }
- for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
- generation *gen = &generations[gen_idx];
- debugBelch("Generation %d current weaks:\n", gen_idx);
- for (StgWeak *weak = gen->weak_ptr_list; weak; weak = weak->link) {
- printClosure((StgClosure*)weak);
+ case UNDERFLOW_FRAME:
+ {
+ StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
+ debugBelch("UNDERFLOW_FRAME(");
+ printPtr((StgPtr)u->next_chunk);
+ debugBelch(")\n");
+ break;
}
- debugBelch("Generation %d old weaks:\n", gen_idx);
- for (StgWeak *weak = gen->old_weak_ptr_list; weak; weak = weak->link) {
- printClosure((StgClosure*)weak);
+
+ case STOP_FRAME:
+ {
+ StgStopFrame* u = (StgStopFrame*)obj;
+ debugBelch("STOP_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(")\n");
+ break;
}
- }
- debugBelch("=========================\n");
-}
+ case ARR_WORDS:
+ {
+ StgWord i;
+ debugBelch("ARR_WORDS(\"");
+ for (i=0; i<arr_words_words((StgArrBytes *)obj); i++)
+ debugBelch("%" FMT_Word, (W_)((StgArrBytes *)obj)->payload[i]);
+ debugBelch("\")\n");
+ break;
+ }
-void printLargeAndPinnedObjects()
-{
- debugBelch("====== PINNED OBJECTS ======\n");
+ case MUT_ARR_PTRS_CLEAN:
+ debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+ break;
- for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
- Capability *cap = capabilities[cap_idx];
+ case MUT_ARR_PTRS_DIRTY:
+ debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+ break;
- debugBelch("Capability %d: Current pinned object block: %p\n",
- cap_idx, (void*)cap->pinned_object_block);
- for (bdescr *bd = cap->pinned_object_blocks; bd; bd = bd->link) {
- debugBelch("%p\n", (void*)bd);
- }
- }
+ case MUT_ARR_PTRS_FROZEN_CLEAN:
+ debugBelch("MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+ break;
- debugBelch("====== LARGE OBJECTS =======\n");
- for (uint32_t gen_idx = 0; gen_idx <= oldest_gen->no; ++gen_idx) {
- generation *gen = &generations[gen_idx];
- debugBelch("Generation %d current large objects:\n", gen_idx);
- for (bdescr *bd = gen->large_objects; bd; bd = bd->link) {
- debugBelch("%p: ", (void*)bd);
- printClosure((StgClosure*)bd->start);
- }
+ case SMALL_MUT_ARR_PTRS_CLEAN:
+ debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
+ (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+ break;
- debugBelch("Generation %d scavenged large objects:\n", gen_idx);
- for (bdescr *bd = gen->scavenged_large_objects; bd; bd = bd->link) {
- debugBelch("%p: ", (void*)bd);
- printClosure((StgClosure*)bd->start);
- }
- }
+ case SMALL_MUT_ARR_PTRS_DIRTY:
+ debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
+ (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+ break;
- debugBelch("============================\n");
-}
+ case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
+ debugBelch("SMALL_MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n",
+ (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+ break;
-/* --------------------------------------------------------------------------
- * Address printing code
- *
- * Uses symbol table in (unstripped executable)
- * ------------------------------------------------------------------------*/
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
+ {
+ StgMVar* mv = (StgMVar*)obj;
-/* --------------------------------------------------------------------------
- * Simple lookup table
- * address -> function name
- * ------------------------------------------------------------------------*/
+ debugBelch("MVAR(head=");
+ if ((StgClosure*)mv->head == &stg_END_TSO_QUEUE_closure) {
+ debugBelch("END_TSO_QUEUE");
+ } else {
+ debugBelch("%p", mv->head);
+ }
-static HashTable * add_to_fname_table = NULL;
+ debugBelch(", tail=");
+ if ((StgClosure*)mv->tail == &stg_END_TSO_QUEUE_closure) {
+ debugBelch("END_TSO_QUEUE");
+ } else {
+ debugBelch("%p", mv->tail);
+ }
-const char *lookupGHCName( void *addr )
-{
- if (add_to_fname_table == NULL)
- return NULL;
+ debugBelch(", value=");
+ if ((StgClosure*)mv->value == &stg_END_TSO_QUEUE_closure) {
+ debugBelch("END_TSO_QUEUE");
+ } else {
+ debugBelch("%p", mv->value);
+ }
+ debugBelch(")\n");
- return lookupHashTable(add_to_fname_table, (StgWord)addr);
-}
+ break;
+ }
-/* --------------------------------------------------------------------------
- * Symbol table loading
- * ------------------------------------------------------------------------*/
+ case TVAR:
+ {
+ StgTVar* tv = (StgTVar*)obj;
+ debugBelch("TVAR(value=%p, wq=%p, num_updates=%" FMT_Word ")\n", tv->current_value, tv->first_watch_queue_entry, tv->num_updates);
+ break;
+ }
-/* Causing linking trouble on Win32 plats, so I'm
- disabling this for now.
-*/
-#if defined(USING_LIBBFD)
-# define PACKAGE 1
-# define PACKAGE_VERSION 1
-/* Those PACKAGE_* defines are workarounds for bfd:
- * https://sourceware.org/bugzilla/show_bug.cgi?id=14243
- * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
- * with user's autoconf-based Cabal packages.
- * It's a shame <bfd.h> checks for unrelated fields instead of actually used
- * macros.
- */
-# include <bfd.h>
+ case MUT_VAR_CLEAN:
+ {
+ StgMutVar* mv = (StgMutVar*)obj;
+ debugBelch("MUT_VAR_CLEAN(var=%p)\n", mv->var);
+ break;
+ }
-/* Fairly ad-hoc piece of code that seems to filter out a lot of
- * rubbish like the obj-splitting symbols
- */
+ case MUT_VAR_DIRTY:
+ {
+ StgMutVar* mv = (StgMutVar*)obj;
+ debugBelch("MUT_VAR_DIRTY(var=%p)\n", mv->var);
+ break;
+ }
-static bool isReal( flagword flags STG_UNUSED, const char *name )
-{
-#if 0
- /* ToDo: make this work on BFD */
- int tp = type & N_TYPE;
- if (tp == N_TEXT || tp == N_DATA) {
- return (name[0] == '_' && name[1] != '_');
- } else {
- return false;
- }
-#else
- if (*name == '\0' ||
- (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
- (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
- return false;
- }
- return true;
-#endif
-}
+ case WEAK:
+ debugBelch("WEAK(");
+ debugBelch("key=%p value=%p finalizer=%p",
+ (StgPtr)(((StgWeak*)obj)->key),
+ (StgPtr)(((StgWeak*)obj)->value),
+ (StgPtr)(((StgWeak*)obj)->finalizer));
+ debugBelch(")\n");
+ /* ToDo: chase 'link' ? */
+ break;
-extern void DEBUG_LoadSymbols( const char *name )
-{
- bfd* abfd;
- char **matching;
+ case TSO:
+ debugBelch("TSO(");
+ debugBelch("%lu (%p)",(unsigned long)(((StgTSO*)obj)->id), (StgTSO*)obj);
+ debugBelch(")\n");
+ break;
- bfd_init();
- abfd = bfd_openr(name, "default");
- if (abfd == NULL) {
- barf("can't open executable %s to get symbol table", name);
- }
- if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
- barf("mismatch");
- }
+ case STACK:
+ debugBelch("STACK\n");
+ break;
- {
- long storage_needed;
- asymbol **symbol_table;
- long number_of_symbols;
- long num_real_syms = 0;
- long i;
+#if 0
+ /* Symptomatic of a problem elsewhere, have it fall-through & fail */
+ case EVACUATED:
+ debugBelch("EVACUATED(");
+ printClosure((StgEvacuated*)obj->evacuee);
+ debugBelch(")\n");
+ break;
+#endif
- storage_needed = bfd_get_symtab_upper_bound (abfd);
+ case COMPACT_NFDATA:
+ debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n",
+ (W_)((StgCompactNFData *)obj)->totalW * (W_)sizeof(W_));
+ break;
- if (storage_needed < 0) {
- barf("can't read symbol table");
- }
- symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
+ case TREC_CHUNK:
+ debugBelch("TREC_CHUNK\n");
+ break;
- number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
+ default:
+ //barf("printClosure %d",get_itbl(obj)->type);
+ debugBelch("*** printClosure: unknown type %d ****\n",
+ (int)get_itbl(obj)->type );
+ barf("printClosure %d",get_itbl(obj)->type);
+ return;
+ }
+}
- if (number_of_symbols < 0) {
- barf("can't canonicalise symbol table");
+static void
+printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
+ uint32_t size )
+{
+ uint32_t i;
+
+ for(i = 0; i < size; i++, bitmap >>= 1 ) {
+ debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
+ if ((bitmap & 1) == 0) {
+ printPtr((P_)payload[i]);
+ debugBelch("\n");
+ } else {
+ debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
}
+ }
+}
- if (add_to_fname_table == NULL)
- add_to_fname_table = allocHashTable();
+static void
+printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
+ uint32_t size )
+{
+ StgWord bmp;
+ uint32_t i, j;
- for( i = 0; i != number_of_symbols; ++i ) {
- symbol_info info;
- bfd_get_symbol_info(abfd,symbol_table[i],&info);
- if (isReal(info.type, info.name)) {
- insertHashTable(add_to_fname_table,
- info.value, (void*)info.name);
- num_real_syms += 1;
+ i = 0;
+ for (bmp=0; i < size; bmp++) {
+ StgWord bitmap = large_bitmap->bitmap[bmp];
+ j = 0;
+ for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
+ debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
+ if ((bitmap & 1) == 0) {
+ printPtr((P_)payload[i]);
+ debugBelch("\n");
+ } else {
+ debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
}
}
-
- IF_DEBUG(interpreter,
- debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
- number_of_symbols, num_real_syms)
- );
-
- stgFree(symbol_table);
}
}
-#else /* USING_LIBBFD */
-
-extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
+void
+printStackChunk( StgPtr sp, StgPtr spBottom )
{
- /* nothing, yet */
-}
+ StgWord bitmap;
+ const StgInfoTable *info;
-#endif /* USING_LIBBFD */
+ ASSERT(sp <= spBottom);
+ for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
-void findPtr(P_ p, int); /* keep gcc -Wall happy */
+ info = get_itbl((StgClosure *)sp);
-int searched = 0;
+ switch (info->type) {
-static int
-findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
-{
- StgPtr q, r, end;
- for (; bd; bd = bd->link) {
- searched++;
- for (q = bd->start; q < bd->free; q++) {
- if (UNTAG_CONST_CLOSURE((StgClosure*)*q) == (const StgClosure *)p) {
- if (i < arr_size) {
- for (r = bd->start; r < bd->free; r = end) {
- // skip over zeroed-out slop
- while (*r == 0) r++;
- if (!LOOKS_LIKE_CLOSURE_PTR(r)) {
- debugBelch("%p found at %p, no closure at %p\n",
- p, q, r);
- break;
- }
- end = r + closure_sizeW((StgClosure*)r);
- if (q < end) {
- debugBelch("%p = ", r);
- printClosure((StgClosure *)r);
- arr[i++] = r;
- break;
- }
- }
- if (r >= bd->free) {
- debugBelch("%p found at %p, closure?", p, q);
- }
- } else {
- return i;
- }
+ case UPDATE_FRAME:
+ case CATCH_FRAME:
+ case UNDERFLOW_FRAME:
+ case STOP_FRAME:
+ printClosure((StgClosure*)sp);
+ continue;
+
+ case RET_SMALL: {
+ StgWord c = *sp;
+ if (c == (StgWord)&stg_ctoi_R1p_info) {
+ debugBelch("tstg_ctoi_ret_R1p_info\n" );
+ } else if (c == (StgWord)&stg_ctoi_R1n_info) {
+ debugBelch("stg_ctoi_ret_R1n_info\n" );
+ } else if (c == (StgWord)&stg_ctoi_F1_info) {
+ debugBelch("stg_ctoi_ret_F1_info\n" );
+ } else if (c == (StgWord)&stg_ctoi_D1_info) {
+ debugBelch("stg_ctoi_ret_D1_info\n" );
+ } else if (c == (StgWord)&stg_ctoi_V_info) {
+ debugBelch("stg_ctoi_ret_V_info\n" );
+ } else if (c == (StgWord)&stg_ap_v_info) {
+ debugBelch("stg_ap_v_info\n" );
+ } else if (c == (StgWord)&stg_ap_f_info) {
+ debugBelch("stg_ap_f_info\n" );
+ } else if (c == (StgWord)&stg_ap_d_info) {
+ debugBelch("stg_ap_d_info\n" );
+ } else if (c == (StgWord)&stg_ap_l_info) {
+ debugBelch("stg_ap_l_info\n" );
+ } else if (c == (StgWord)&stg_ap_n_info) {
+ debugBelch("stg_ap_n_info\n" );
+ } else if (c == (StgWord)&stg_ap_p_info) {
+ debugBelch("stg_ap_p_info\n" );
+ } else if (c == (StgWord)&stg_ap_pp_info) {
+ debugBelch("stg_ap_pp_info\n" );
+ } else if (c == (StgWord)&stg_ap_ppp_info) {
+ debugBelch("stg_ap_ppp_info\n" );
+ } else if (c == (StgWord)&stg_ap_pppp_info) {
+ debugBelch("stg_ap_pppp_info\n" );
+ } else if (c == (StgWord)&stg_ap_ppppp_info) {
+ debugBelch("stg_ap_ppppp_info\n" );
+ } else if (c == (StgWord)&stg_ap_pppppp_info) {
+ debugBelch("stg_ap_pppppp_info\n" );
+ } else if (c == (StgWord)&stg_ret_v_info) {
+ debugBelch("stg_ret_v_info\n" );
+ } else if (c == (StgWord)&stg_ret_p_info) {
+ debugBelch("stg_ret_p_info\n" );
+ } else if (c == (StgWord)&stg_ret_n_info) {
+ debugBelch("stg_ret_n_info\n" );
+ } else if (c == (StgWord)&stg_ret_f_info) {
+ debugBelch("stg_ret_f_info\n" );
+ } else if (c == (StgWord)&stg_ret_d_info) {
+ debugBelch("stg_ret_d_info\n" );
+ } else if (c == (StgWord)&stg_ret_l_info) {
+ debugBelch("stg_ret_l_info\n" );
+#if defined(PROFILING)
+ } else if (c == (StgWord)&stg_restore_cccs_info) {
+ debugBelch("stg_restore_cccs_info\n" );
+ fprintCCS(stderr, (CostCentreStack*)sp[1]);
+ debugBelch("\n" );
+ continue;
+ } else if (c == (StgWord)&stg_restore_cccs_eval_info) {
+ debugBelch("stg_restore_cccs_eval_info\n" );
+ fprintCCS(stderr, (CostCentreStack*)sp[1]);
+ debugBelch("\n" );
+ continue;
+#endif
+ } else {
+ debugBelch("RET_SMALL (%p)\n", info);
}
+ bitmap = info->layout.bitmap;
+ printSmallBitmap(spBottom, sp+1,
+ BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
+ continue;
}
- }
- return i;
-}
-void
-findPtr(P_ p, int follow)
-{
- uint32_t g, n;
- bdescr *bd;
- const int arr_size = 1024;
- StgPtr arr[arr_size];
- int i = 0;
- searched = 0;
+ case RET_BCO: {
+ StgBCO *bco;
-#if 0
- // We can't search the nursery, because we don't know which blocks contain
- // valid data, because the bd->free pointers in the nursery are only reset
- // just before a block is used.
- for (n = 0; n < n_capabilities; n++) {
- bd = nurseries[i].blocks;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
- if (i >= arr_size) return;
- }
-#endif
+ bco = ((StgBCO *)sp[1]);
- for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
- bd = generations[g].blocks;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
- bd = generations[g].large_objects;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
- if (i >= arr_size) return;
- for (n = 0; n < n_capabilities; n++) {
- i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
- arr, arr_size, i);
- i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
- arr, arr_size, i);
- }
- if (i >= arr_size) return;
- }
- if (follow && i == 1) {
- debugBelch("-->\n");
- findPtr(arr[0], 1);
- }
-}
+ debugBelch("RET_BCO (%p)\n", sp);
+ printLargeBitmap(spBottom, sp+2,
+ BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
+ continue;
+ }
-const char *what_next_strs[] = {
- [0] = "(unknown)",
- [ThreadRunGHC] = "ThreadRunGHC",
- [ThreadInterpret] = "ThreadInterpret",
- [ThreadKilled] = "ThreadKilled",
- [ThreadComplete] = "ThreadComplete"
-};
+ case RET_BIG:
+ barf("todo");
-#else /* DEBUG */
-void printPtr( StgPtr p )
-{
- debugBelch("ptr 0x%p (enable -DDEBUG for more info) " , p );
+ case RET_FUN:
+ {
+ const StgFunInfoTable *fun_info;
+ StgRetFun *ret_fun;
+
+ ret_fun = (StgRetFun *)sp;
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
+ switch (fun_info->f.fun_type) {
+ case ARG_GEN:
+ printSmallBitmap(spBottom, sp+2,
+ BITMAP_BITS(fun_info->f.b.bitmap),
+ BITMAP_SIZE(fun_info->f.b.bitmap));
+ break;
+ case ARG_GEN_BIG:
+ printLargeBitmap(spBottom, sp+2,
+ GET_FUN_LARGE_BITMAP(fun_info),
+ GET_FUN_LARGE_BITMAP(fun_info)->size);
+ break;
+ default:
+ printSmallBitmap(spBottom, sp+2,
+ BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
+ BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
+ break;
+ }
+ continue;
+ }
+
+ default:
+ debugBelch("unknown object %d\n", (int)info->type);
+ barf("printStackChunk");
+ }
+ }
}
-void printObj( StgClosure *obj )
+void printStack( StgStack *stack )
{
- debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
+ printStackChunk( stack->sp, stack->stack + stack->stack_size );
}
-#endif /* DEBUG */
-
/* -----------------------------------------------------------------------------
Closure types
=====================================
rts/Printer.h
=====================================
@@ -20,9 +20,9 @@ const char * info_type ( const StgClosure *closure );
const char * info_type_by_ip ( const StgInfoTable *ip );
const char * info_update_frame ( const StgClosure *closure );
-#if defined(DEBUG)
-extern void printStack( StgStack *stack );
extern void printClosure ( const StgClosure *obj );
+
+#if defined(DEBUG)
extern void printStackChunk ( StgPtr sp, StgPtr spLim );
extern void printTSO ( StgTSO *tso );
extern void printMutableList( bdescr *bd );
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14599b016f8f71ac1207411f4cdecf5a442624ae
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14599b016f8f71ac1207411f4cdecf5a442624ae
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201011/30bc1a3a/attachment-0001.html>
More information about the ghc-commits
mailing list