#include "PosixSource.h"
#include "Rts.h"
+#include "rts/Bytecodes.h" /* for InstrPtr */
+
#include "Printer.h"
#include "RtsUtils.h"
#ifdef DEBUG
-#include "RtsFlags.h"
-#include "MBlock.h"
-#include "Storage.h"
-#include "Bytecodes.h" /* for InstrPtr */
#include "Disassembler.h"
#include "Apply.h"
-#include <stdlib.h>
#include <string.h>
-#if defined(GRAN) || defined(PAR)
-// HWL: explicit fixed header size to make debugging easier
-int fixed_hs = sizeof(StgHeader), itbl_sz = sizeofW(StgInfoTable),
- uf_sz=sizeofW(StgUpdateFrame);
-#endif
-
/* --------------------------------------------------------------------------
* local function decls
* ------------------------------------------------------------------------*/
static void enZcode ( char *in, char *out );
#endif
static char unZcode ( char ch );
-const char * lookupGHCName ( void *addr );
static void printZcoded ( const char *raw );
/* --------------------------------------------------------------------------
void
printClosure( StgClosure *obj )
{
+ obj = UNTAG_CLOSURE(obj);
+
StgInfoTable *info;
-
info = get_itbl(obj);
switch ( info->type ) {
case CONSTR_NOCAF_STATIC:
{
StgWord i, j;
+
#ifdef PROFILING
- debugBelch("%s(", info->prof.closure_desc);
+ debugBelch("%s(", GET_PROF_DESC(info));
debugBelch("%s", obj->header.prof.ccs->cc->label);
#else
debugBelch("CONSTR(");
case THUNK_STATIC:
/* ToDo: will this work for THUNK_STATIC too? */
#ifdef PROFILING
- printThunkObject((StgThunk *)obj,info->prof.closure_desc);
+ printThunkObject((StgThunk *)obj,GET_PROF_DESC(info));
#else
printThunkObject((StgThunk *)obj,"THUNK");
#endif
case AP:
{
- StgAP* ap = stgCast(StgAP*,obj);
+ StgAP* ap = (StgAP*)obj;
StgWord i;
debugBelch("AP("); printPtr((StgPtr)ap->fun);
for (i = 0; i < ap->n_args; ++i) {
case PAP:
{
- StgPAP* pap = stgCast(StgPAP*,obj);
+ StgPAP* pap = (StgPAP*)obj;
StgWord i;
debugBelch("PAP/%d(",pap->arity);
printPtr((StgPtr)pap->fun);
case AP_STACK:
{
- StgAP_STACK* ap = stgCast(StgAP_STACK*,obj);
+ StgAP_STACK* ap = (StgAP_STACK*)obj;
StgWord i;
debugBelch("AP_STACK("); printPtr((StgPtr)ap->fun);
for (i = 0; i < ap->size; ++i) {
case IND:
debugBelch("IND(");
- printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
case IND_OLDGEN:
debugBelch("IND_OLDGEN(");
- printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
case IND_PERM:
debugBelch("IND(");
- printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
case IND_OLDGEN_PERM:
debugBelch("IND_OLDGEN_PERM(");
- printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
case IND_STATIC:
debugBelch("IND_STATIC(");
- printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+ printPtr((StgPtr)((StgInd*)obj)->indirectee);
debugBelch(")\n");
break;
/* Cannot happen -- use default case.
case RET_BCO:
case RET_SMALL:
- case RET_VEC_SMALL:
case RET_BIG:
- case RET_VEC_BIG:
case RET_DYN:
case RET_FUN:
*/
case UPDATE_FRAME:
{
- StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
+ StgUpdateFrame* u = (StgUpdateFrame*)obj;
debugBelch("UPDATE_FRAME(");
printPtr((StgPtr)GET_INFO(u));
debugBelch(",");
case CATCH_FRAME:
{
- StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
+ StgCatchFrame* u = (StgCatchFrame*)obj;
debugBelch("CATCH_FRAME(");
printPtr((StgPtr)GET_INFO(u));
debugBelch(",");
case STOP_FRAME:
{
- StgStopFrame* u = stgCast(StgStopFrame*,obj);
+ StgStopFrame* u = (StgStopFrame*)obj;
debugBelch("STOP_FRAME(");
printPtr((StgPtr)GET_INFO(u));
debugBelch(")\n");
debugBelch("BH\n");
break;
- case SE_BLACKHOLE:
- debugBelch("SE_BH\n");
- break;
-
- case SE_CAF_BLACKHOLE:
- debugBelch("SE_CAF_BH\n");
- break;
-
case ARR_WORDS:
{
StgWord i;
debugBelch("MUT_ARR_PTRS_FROZEN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
break;
- case MVAR:
+ case MVAR_CLEAN:
+ case MVAR_DIRTY:
{
StgMVar* mv = (StgMVar*)obj;
debugBelch("MVAR(head=%p, tail=%p, value=%p)\n", mv->head, mv->tail, mv->value);
debugBelch(")\n");
break;
-#if defined(PAR)
- case BLOCKED_FETCH:
- debugBelch("BLOCKED_FETCH(");
- printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
- printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
- debugBelch(")\n");
- break;
-
- case FETCH_ME:
- debugBelch("FETCH_ME(");
- printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- debugBelch(")\n");
- break;
-
- case FETCH_ME_BQ:
- debugBelch("FETCH_ME_BQ(");
- // printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
- debugBelch(")\n");
- break;
-#endif
-
-#if defined(GRAN) || defined(PAR)
- case RBH:
- debugBelch("RBH(");
- printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
- debugBelch(")\n");
- break;
-
-#endif
-
#if 0
/* Symptomatic of a problem elsewhere, have it fall-through & fail */
case EVACUATED:
break;
#endif
-#if defined(PAR) && defined(DIST)
- case REMOTE_REF:
- debugBelch("REMOTE_REF(");
- printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- debugBelch(")\n");
- break;
-#endif
-
default:
//barf("printClosure %d",get_itbl(obj)->type);
debugBelch("*** printClosure: unknown type %d ****\n",
}
case RET_SMALL:
- case RET_VEC_SMALL:
debugBelch("RET_SMALL (%p)\n", info);
bitmap = info->layout.bitmap;
printSmallBitmap(spBottom, sp+1,
}
case RET_BIG:
- case RET_VEC_BIG:
barf("todo");
case RET_FUN:
"IND_STATIC",
"RET_BCO",
"RET_SMALL",
- "RET_VEC_SMALL",
"RET_BIG",
- "RET_VEC_BIG",
"RET_DYN",
"RET_FUN",
"UPDATE_FRAME",
void findPtr(P_ p, int); /* keep gcc -Wall happy */
+int searched = 0;
+
+static int
+findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
+{
+ StgPtr q, r;
+ for (; bd; bd = bd->link) {
+ searched++;
+ for (q = bd->start; q < bd->free; q++) {
+ if (UNTAG_CLOSURE((StgClosure*)*q) == (StgClosure *)p) {
+ if (i < arr_size) {
+ r = q;
+ while (HEAP_ALLOCED((StgPtr)*r) || !LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
+ r--;
+ }
+ debugBelch("%p = ", r);
+ printClosure((StgClosure *)r);
+ arr[i++] = r;
+ } else {
+ return i;
+ }
+ }
+ }
+ }
+ return i;
+}
+
void
findPtr(P_ p, int follow)
{
nat s, g;
- P_ q, r;
bdescr *bd;
#if defined(__GNUC__)
const int arr_size = 1024;
#endif
StgPtr arr[arr_size];
int i = 0;
+ searched = 0;
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
for (s = 0; s < generations[g].n_steps; s++) {
bd = generations[g].steps[s].blocks;
- for (; bd; bd = bd->link) {
- for (q = bd->start; q < bd->free; q++) {
- if (*q == (W_)p) {
- if (i < arr_size) {
- r = q;
- while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
- r--;
- }
- debugBelch("%p = ", r);
- printClosure((StgClosure *)r);
- arr[i++] = r;
- } else {
- return;
- }
- }
- }
- }
+ i = findPtrBlocks(p,bd,arr,arr_size,i);
+ bd = generations[g].steps[s].large_objects;
+ i = findPtrBlocks(p,bd,arr,arr_size,i);
+ if (i >= arr_size) return;
}
}
if (follow && i == 1) {
}
}
+/* prettyPrintClosure() is for printing out a closure using the data constructor
+ names found in the info tables. Closures are printed in a fashion that resembles
+ their Haskell representation. Useful during debugging.
+
+ Todo: support for more closure types, and support for non pointer fields in the
+ payload.
+*/
+
+void prettyPrintClosure_ (StgClosure *);
+
+void prettyPrintClosure (StgClosure *obj)
+{
+ prettyPrintClosure_ (obj);
+ debugBelch ("\n");
+}
+
+void prettyPrintClosure_ (StgClosure *obj)
+{
+ StgInfoTable *info;
+ StgConInfoTable *con_info;
+
+ /* collapse any indirections */
+ unsigned int type;
+ type = get_itbl(obj)->type;
+
+ while (type == IND ||
+ type == IND_STATIC ||
+ type == IND_OLDGEN ||
+ type == IND_PERM ||
+ type == IND_OLDGEN_PERM)
+ {
+ obj = ((StgInd *)obj)->indirectee;
+ type = get_itbl(obj)->type;
+ }
+
+ /* find the info table for this object */
+ info = get_itbl(obj);
+
+ /* determine what kind of object we have */
+ switch (info->type)
+ {
+ /* full applications of data constructors */
+ case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_2_0:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ {
+ nat i;
+ char *descriptor;
+
+ /* find the con_info for the constructor */
+ con_info = get_con_itbl (obj);
+
+ /* obtain the name of the constructor */
+ descriptor = GET_CON_DESC(con_info);
+
+ debugBelch ("(%s", descriptor);
+
+ /* process the payload of the closure */
+ /* we don't handle non pointers at the moment */
+ for (i = 0; i < info->layout.payload.ptrs; i++)
+ {
+ debugBelch (" ");
+ prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
+ }
+ debugBelch (")");
+ break;
+ }
+
+ /* if it isn't a constructor then just print the closure type */
+ default:
+ {
+ debugBelch ("<%s>", info_type(obj));
+ break;
+ }
+ }
+}
+
#else /* DEBUG */
void printPtr( StgPtr p )
{
{
debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
}
+
+
#endif /* DEBUG */
projects / ghc-hetmet.git / blobdiff