+++ /dev/null
-/*
- Time-stamp: <Sun Mar 18 2001 19:32:56 Stardate: [-30]6349.07 hwloidl>
-
- Various debugging routines for GranSim and GUM
-*/
-
-#if defined(DEBUG) && (defined(GRAN) || defined(PAR)) /* whole file */
-
-//@node Debugging routines for GranSim and GUM, , ,
-//@section Debugging routines for GranSim and GUM
-
-//@menu
-//* Includes::
-//* Constants and Variables::
-//* Closures::
-//* Threads::
-//* Events::
-//* Sparks::
-//* Processors::
-//* Shortcuts::
-//* Printing info type::
-//* Printing Pack:et Contents::
-//* End of File::
-//@end menu
-//*/
-
-//@node Includes, Prototypes, Debugging routines for GranSim and GUM, Debugging routines for GranSim and GUM
-//@subsection Includes
-
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "GranSimRts.h"
-#include "ParallelRts.h"
-#include "StgMiscClosures.h"
-#include "Printer.h"
-# if defined(DEBUG)
-# include "Hash.h"
-# include "Storage.h"
-# include "ParallelDebug.h"
-# endif
-
-//@node Prototypes, Constants and Variables, Includes, Debugging routines for GranSim and GUM
-//@subsection Prototypes
-/*
-rtsBool isOffset(globalAddr *ga);
-rtsBool isFixed(globalAddr *ga);
-*/
-//@node Constants and Variables, Closures, Prototypes, Debugging routines for GranSim and GUM
-//@subsection Constants and Variables
-
-static HashTable *tmpClosureTable; // used in GraphFingerPrint and PrintGraph
-
-#if defined(PAR)
-static char finger_print_char[] = {
- '/', /* INVALID_OBJECT 0 */
- 'C', /* CONSTR 1 */
- 'C', /* CONSTR_1_0 2 */
- 'C', /* CONSTR_0_1 3 */
- 'C', /* CONSTR_2_0 4 */
- 'C', /* CONSTR_1_1 5 */
- 'C', /* CONSTR_0_2 6 */
- 'I', /* CONSTR_INTLIKE 7 */
- 'I', /* CONSTR_CHARLIKE 8 */
- 'S', /* CONSTR_STATIC 9 */
- 'S', /* CONSTR_NOCAF_STATIC 10 */
- 'F', /* FUN 11 */
- 'F', /* FUN_1_0 12 */
- 'F', /* FUN_0_1 13 */
- 'F', /* FUN_2_0 14 */
- 'F', /* FUN_1_1 15 */
- 'F', /* FUN_0_2 16 */
- 'S', /* FUN_STATIC 17 */
- 'T', /* THUNK 18 */
- 'T', /* THUNK_1_0 19 */
- 'T', /* THUNK_0_1 20 */
- 'T', /* THUNK_2_0 21 */
- 'T', /* THUNK_1_1 22 */
- 'T', /* THUNK_0_2 23 */
- 'S', /* THUNK_STATIC 24 */
- 'E', /* THUNK_SELECTOR 25 */
- 'b', /* BCO 26 */
- 'p', /* AP_UPD 27 */
- 'p', /* PAP 28 */
- '_', /* IND 29 */
- '_', /* IND_OLDGEN 30 */
- '_', /* IND_PERM 31 */
- '_', /* IND_OLDGEN_PERM 32 */
- '_', /* IND_STATIC 33 */
- '?', /* ***unused*** 34 */
- '?', /* ***unused*** 35 */
- '^', /* RET_BCO 36 */
- '^', /* RET_SMALL 37 */
- '^', /* RET_VEC_SMALL 38 */
- '^', /* RET_BIG 39 */
- '^', /* RET_VEC_BIG 40 */
- '^', /* RET_DYN 41 */
- '~', /* UPDATE_FRAME 42 */
- '~', /* CATCH_FRAME 43 */
- '~', /* STOP_FRAME 44 */
- '~', /* SEQ_FRAME 45 */
- 'o', /* CAF_BLACKHOLE 46 */
- 'o', /* BLACKHOLE 47 */
- 'o', /* BLACKHOLE_BQ 48 */
- 'o', /* SE_BLACKHOLE 49 */
- 'o', /* SE_CAF_BLACKHOLE 50 */
- 'm', /* MVAR 51 */
- 'a', /* ARR_WORDS 52 */
- 'a', /* MUT_ARR_PTRS 53 */
- 'a', /* MUT_ARR_PTRS_FROZEN 54 */
- 'q', /* MUT_VAR 55 */
- 'w', /* WEAK 56 */
- 'f', /* FOREIGN 57 */
- 's', /* STABLE_NAME 58 */
- '@', /* TSO 59 */
- '#', /* BLOCKED_FETCH 60 */
- '>', /* FETCH_ME 61 */
- '>', /* FETCH_ME_BQ 62 */
- '$', /* RBH 63 */
- 'v', /* EVACUATED 64 */
- '>' /* REMOTE_REF 65 */
- /* ASSERT(there are N_CLOSURE_TYPES (==66) in this arrary) */
-};
-#endif /* PAR */
-
-#if defined(GRAN) && defined(GRAN_CHECK)
-//@node Closures, Threads, Constants and Variables, Debugging routines for GranSim and GUM
-//@subsection Closures
-
-void
-G_PRINT_NODE(node)
-StgClosure* node;
-{
- StgInfoTable *info_ptr;
- StgTSO* bqe;
- nat size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0;
- char info_hdr_ty[80], info_ty[80];
-
- if (node==NULL) {
- fprintf(stderr,"NULL\n");
- return;
- } else if (node==END_TSO_QUEUE) {
- fprintf(stderr,"END_TSO_QUEUE\n");
- return;
- }
- /* size_and_ptrs(node,&size,&ptrs); */
- info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_hdr_ty);
-
- /* vhs = var_hdr_size(node); */
- display_info_type(info_ptr,info_ty);
-
- fprintf(stderr,"Node: 0x%lx", node);
-
-#if defined(PAR)
- fprintf(stderr," [GA: 0x%lx]",GA(node));
-#endif
-
-#if defined(USE_COST_CENTRES)
- fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
-#endif
-
-#if defined(GRAN)
- fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
-#endif
-
- if (info_ptr->type==TSO)
- fprintf(stderr," TSO: 0x%lx (%x) IP: 0x%lx (%s), type %s \n ",
- (StgTSO*)node, ((StgTSO*)node)->id, info_ptr, info_hdr_ty, info_ty);
- else
- fprintf(stderr," IP: 0x%lx (%s), type %s \n VHS: %d, size: %ld, ptrs:%ld, nonptrs: %ld\n ",
- info_ptr,info_hdr_ty,info_ty,vhs,size,ptrs,nonptrs);
-
- /* For now, we ignore the variable header */
-
- fprintf(stderr," Ptrs: ");
- for(i=0; i < ptrs; ++i)
- {
- if ( (i+1) % 6 == 0)
- fprintf(stderr,"\n ");
- fprintf(stderr," 0x%lx[P]",node->payload[i]);
- };
-
- fprintf(stderr," Data: ");
- for(i=0; i < nonptrs; ++i)
- {
- if( (i+1) % 6 == 0)
- fprintf(stderr,"\n ");
- fprintf(stderr," %lu[D]",node->payload[ptrs+i]);
- }
- fprintf(stderr, "\n");
-
-
- switch (info_ptr->type)
- {
- case TSO:
- fprintf(stderr,"\n TSO_LINK: %#lx",
- ((StgTSO*)node)->link);
- break;
-
- case BLACKHOLE:
- case RBH:
- bqe = ((StgBlockingQueue*)node)->blocking_queue;
- fprintf(stderr," BQ of %#lx: ", node);
- G_PRINT_BQ(bqe);
- break;
- case FETCH_ME:
- case FETCH_ME_BQ:
- printf("Panic: found FETCH_ME or FETCH_ME_BQ Infotable in GrAnSim system.\n");
- break;
- default:
- /* do nothing */
- }
-}
-
-void
-G_PPN(node) /* Extracted from PrintPacket in Pack.lc */
-StgClosure* node;
-{
- StgInfoTable *info ;
- nat size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0, locn = 0;
- char info_type[80];
-
- /* size_and_ptrs(node,&size,&ptrs); */
- info = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type);
-
- if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
- info->type == BLACKHOLE || info->type == RBH )
- size = ptrs = nonptrs = vhs = 0;
-
- if (closure_THUNK(node)) {
- if (!closure_UNPOINTED(node))
- fputs("SHARED ", stderr);
- else
- fputs("UNSHARED ", stderr);
- }
- if (info->type==BLACKHOLE) {
- fputs("BLACK HOLE\n", stderr);
- } else {
- /* Fixed header */
- fprintf(stderr, "(%s) FH [%#lx", info_type, node[locn++]);
- for (i = 1; i < _HS; i++)
- fprintf(stderr, " %#lx", node[locn++]);
-
- /* Variable header */
- if (vhs > 0) {
- fprintf(stderr, "] VH [%#lx", node->payload[0]);
-
- for (i = 1; i < vhs; i++)
- fprintf(stderr, " %#lx", node->payload[i]);
- }
-
- fprintf(stderr, "] PTRS %u", ptrs);
-
- /* Non-pointers */
- if (nonptrs > 0) {
- fprintf(stderr, " NPTRS [%#lx", node->payload[ptrs]);
-
- for (i = 1; i < nonptrs; i++)
- fprintf(stderr, " %#lx", node->payload[ptrs+i]);
-
- putc(']', stderr);
- }
- putc('\n', stderr);
- }
-
-}
-
-#if 0
-// ToDo: fix this!! -- HWL
-void
-G_INFO_TABLE(node)
-StgClosure *node;
-{
- StgInfoTable *info_ptr;
- nat size = 0, ptrs = 0, nonptrs = 0, vhs = 0;
- char info_type[80], hdr_type[80];
-
- info_hdr_type(info_ptr, hdr_type);
-
- // get_itbl(node);
- info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type);
- fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
- info_type,info_ptr,(W_) ENTRY_CODE(info_ptr),
- size, ptrs);
- // INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
-
- if (closure_THUNK(node) && !closure_UNPOINTED(node) ) {
- fprintf(stderr," RBH InfoPtr: %#lx\n",
- RBH_INFOPTR(info_ptr));
- }
-
-#if defined(PAR)
- fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
-#endif
-
-#if defined(USE_COST_CENTRES)
- fprintf(stderr,"Cost Centre (?): 0x%lx\n",INFO_CAT(info_ptr));
-#endif
-
-#if defined(_INFO_COPYING)
- fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
- INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
-#endif
-
-#if defined(_INFO_COMPACTING)
- fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
- (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
- fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t",
- (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
-#if 0 /* avoid INFO_TYPE */
- if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
- fprintf(stderr,"plus specialised code\n");
- else
- fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
-#endif /* 0 */
-#endif /* _INFO_COMPACTING */
-}
-#endif /* 0 */
-
-//@cindex G_PRINT_BQ
-void
-G_PRINT_BQ(node)
-StgClosure* node;
-{
- StgInfoTable *info;
- StgTSO *tso, *last;
- char str[80], str0[80];
-
- fprintf(stderr,"\n[PE %d] @ %lu BQ: ",
- CurrentProc,CurrentTime[CurrentProc]);
- if ( node == (StgClosure*)NULL ) {
- fprintf(stderr," NULL.\n");
- return;
- }
- if ( node == END_TSO_QUEUE ) {
- fprintf(stderr," _|_\n");
- return;
- }
- tso = ((StgBlockingQueue*)node)->blocking_queue;
- while (node != END_TSO_QUEUE) {
- PEs proc;
-
- /* Find where the tso lives */
- proc = where_is(node);
- info = get_itbl(node);
-
- switch (info->type) {
- case TSO:
- strcpy(str0,"TSO");
- break;
- case BLOCKED_FETCH:
- strcpy(str0,"BLOCKED_FETCH");
- break;
- default:
- strcpy(str0,"???");
- break;
- }
-
- if(proc == CurrentProc)
- fprintf(stderr," %#lx (%x) L %s,",
- node, ((StgBlockingQueue*)node)->blocking_queue, str0);
- else
- fprintf(stderr," %#lx (%x) G (PE %d) %s,",
- node, ((StgBlockingQueue*)node)->blocking_queue, proc, str0);
-
- last = tso;
- tso = last->link;
- }
- if ( tso == END_TSO_QUEUE )
- fprintf(stderr," _|_\n");
-}
-
-//@node Threads, Events, Closures, Debugging routines for GranSim and GUM
-//@subsection Threads
-
-void
-G_CURR_THREADQ(verbose)
-StgInt verbose;
-{
- fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
- G_THREADQ(run_queue_hd, verbose);
-}
-
-void
-G_THREADQ(closure, verbose)
-StgTSO* closure;
-StgInt verbose;
-{
- StgTSO* x;
-
- fprintf(stderr,"Thread Queue: ");
- for (x=closure; x!=END_TSO_QUEUE; x=x->link)
- if (verbose)
- G_TSO(x,0);
- else
- fprintf(stderr," %#lx",x);
-
- if (closure==END_TSO_QUEUE)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-G_TSO(closure,verbose)
-StgTSO* closure;
-StgInt verbose;
-{
-
- if (closure==END_TSO_QUEUE) {
- fprintf(stderr,"TSO at %#lx is END_TSO_QUEUE!\n");
- return;
- }
-
- if ( verbose & 0x08 ) { /* short info */
- fprintf(stderr,"[TSO @ %#lx, PE %d]: Id: %#lx, Link: %#lx\n",
- closure,where_is(closure),
- closure->id,closure->link);
- return;
- }
-
- fprintf(stderr,"TSO at %#lx has the following contents:\n",
- closure);
-
- fprintf(stderr,"> Id: \t%#lx",closure->id);
- // fprintf(stderr,"\tstate: \t%#lx",closure->state);
- fprintf(stderr,"\twhat_next: \t%#lx",closure->what_next);
- fprintf(stderr,"\tlink: \t%#lx\n",closure->link);
- fprintf(stderr,"\twhy_blocked: \t%d", closure->why_blocked);
- fprintf(stderr,"\tblock_info: \t%p\n", closure->block_info);
- // fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
- fprintf(stderr,">PRI: \t%#lx", closure->gran.pri);
- fprintf(stderr,"\tMAGIC: \t%#lx %s\n", closure->gran.magic,
- (closure->gran.magic==TSO_MAGIC ? "it IS a TSO" : "THIS IS NO TSO!!"));
- if ( verbose & 0x04 ) {
- fprintf(stderr, "Stack: stack @ %#lx (stack_size: %u; max_stack_size: %u)\n",
- closure->stack, closure->stack_size, closure->max_stack_size);
- fprintf(stderr, " sp: %#lx, su: %#lx, splim: %#lx\n",
- closure->sp, closure->su, closure->splim);
- }
- // fprintf(stderr,"\n");
- if (verbose & 0x01) {
- // fprintf(stderr,"} LOCKED: \t%#lx",closure->locked);
- fprintf(stderr,"} SPARKNAME: \t%#lx\n", closure->gran.sparkname);
- fprintf(stderr,"} STARTEDAT: \t%#lx", closure->gran.startedat);
- fprintf(stderr,"\tEXPORTED: \t%#lx\n", closure->gran.exported);
- fprintf(stderr,"} BASICBLOCKS: \t%#lx", closure->gran.basicblocks);
- fprintf(stderr,"\tALLOCS: \t%#lx\n", closure->gran.allocs);
- fprintf(stderr,"} EXECTIME: \t%#lx", closure->gran.exectime);
- fprintf(stderr,"\tFETCHTIME: \t%#lx\n", closure->gran.fetchtime);
- fprintf(stderr,"} FETCHCOUNT: \t%#lx", closure->gran.fetchcount);
- fprintf(stderr,"\tBLOCKTIME: \t%#lx\n", closure->gran.blocktime);
- fprintf(stderr,"} BLOCKCOUNT: \t%#lx", closure->gran.blockcount);
- fprintf(stderr,"\tBLOCKEDAT: \t%#lx\n", closure->gran.blockedat);
- fprintf(stderr,"} GLOBALSPARKS:\t%#lx", closure->gran.globalsparks);
- fprintf(stderr,"\tLOCALSPARKS:\t%#lx\n", closure->gran.localsparks);
- }
- if ( verbose & 0x02 ) {
- fprintf(stderr,"BQ that starts with this TSO: ");
- G_PRINT_BQ(closure);
- }
-}
-
-//@node Events, Sparks, Threads, Debugging routines for GranSim and GUM
-//@subsection Events
-
-void
-G_EVENT(event, verbose)
-rtsEventQ event;
-StgInt verbose;
-{
- if (verbose) {
- print_event(event);
- }else{
- fprintf(stderr," %#lx",event);
- }
-}
-
-void
-G_EVENTQ(verbose)
-StgInt verbose;
-{
- extern rtsEventQ EventHd;
- rtsEventQ x;
-
- fprintf(stderr,"RtsEventQ (hd @%#lx):\n",EventHd);
- for (x=EventHd; x!=NULL; x=x->next) {
- G_EVENT(x,verbose);
- }
- if (EventHd==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-G_PE_EQ(pe,verbose)
-PEs pe;
-StgInt verbose;
-{
- extern rtsEventQ EventHd;
- rtsEventQ x;
-
- fprintf(stderr,"RtsEventQ (hd @%#lx):\n",EventHd);
- for (x=EventHd; x!=NULL; x=x->next) {
- if (x->proc==pe)
- G_EVENT(x,verbose);
- }
- if (EventHd==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-//@node Sparks, Processors, Events, Debugging routines for GranSim and GUM
-//@subsection Sparks
-
-void
-G_SPARK(spark, verbose)
-rtsSparkQ spark;
-StgInt verbose;
-{
- if (spark==(rtsSpark*)NULL) {
- belch("G_SPARK: NULL spark; aborting");
- return;
- }
- if (verbose)
- print_spark(spark);
- else
- fprintf(stderr," %#lx",spark);
-}
-
-void
-G_SPARKQ(spark,verbose)
-rtsSparkQ spark;
-StgInt verbose;
-{
- rtsSparkQ x;
-
- if (spark==(rtsSpark*)NULL) {
- belch("G_SPARKQ: NULL spark; aborting");
- return;
- }
-
- fprintf(stderr,"RtsSparkQ (hd @%#lx):\n",spark);
- for (x=spark; x!=NULL; x=x->next) {
- G_SPARK(x,verbose);
- }
- if (spark==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-G_CURR_SPARKQ(verbose)
-StgInt verbose;
-{
- G_SPARKQ(pending_sparks_hd,verbose);
-}
-
-//@node Processors, Shortcuts, Sparks, Debugging routines for GranSim and GUM
-//@subsection Processors
-
-void
-G_PROC(proc,verbose)
-StgInt proc;
-StgInt verbose;
-{
- extern rtsEventQ EventHd;
- extern char *proc_status_names[];
-
- fprintf(stderr,"Status of proc %d at time %d (%#lx): %s (%s)\n",
- proc,CurrentTime[proc],CurrentTime[proc],
- (CurrentProc==proc)?"ACTIVE":"INACTIVE",
- proc_status_names[procStatus[proc]]);
- G_THREADQ(run_queue_hds[proc],verbose & 0x2);
- if ( (CurrentProc==proc) )
- G_TSO(CurrentTSO,1);
-
- if (EventHd!=NULL)
- fprintf(stderr,"Next event (%s) is on proc %d\n",
- event_names[EventHd->evttype],EventHd->proc);
-
- if (verbose & 0x1) {
- fprintf(stderr,"\nREQUIRED sparks: ");
- G_SPARKQ(pending_sparks_hds[proc],1);
- fprintf(stderr,"\nADVISORY_sparks: ");
- G_SPARKQ(pending_sparks_hds[proc],1);
- }
-}
-
-//@node Shortcuts, Printing info type, Processors, Debugging routines for GranSim and GUM
-//@subsection Shortcuts
-
-/* Debug Processor */
-void
-GP(proc)
-StgInt proc;
-{ G_PROC(proc,1);
-}
-
-/* Debug Current Processor */
-void
-GCP(){ G_PROC(CurrentProc,2); }
-
-/* Debug TSO */
-void
-GT(StgPtr tso){
- G_TSO(tso,1);
-}
-
-/* Debug CurrentTSO */
-void
-GCT(){
- fprintf(stderr,"Current Proc: %d\n",CurrentProc);
- G_TSO(CurrentTSO,1);
-}
-
-/* Shorthand for debugging event queue */
-void
-GEQ() { G_EVENTQ(1); }
-
-/* Shorthand for debugging thread queue of a processor */
-void
-GTQ(PEs p) { G_THREADQ(run_queue_hds[p],1); }
-
-/* Shorthand for debugging thread queue of current processor */
-void
-GCTQ() { G_THREADQ(run_queue_hds[CurrentProc],1); }
-
-/* Shorthand for debugging spark queue of a processor */
-void
-GSQ(PEs p) { G_SPARKQ(pending_sparks_hds[p],1); }
-
-/* Shorthand for debugging spark queue of current processor */
-void
-GCSQ() { G_CURR_SPARKQ(1); }
-
-/* Shorthand for printing a node */
-void
-GN(StgPtr node) { G_PRINT_NODE(node); }
-
-/* Shorthand for printing info table */
-#if 0
-// ToDo: fix -- HWL
-void
-GIT(StgPtr node) { G_INFO_TABLE(node); }
-#endif
-
-void
-printThreadQPtrs(void)
-{
- PEs p;
- for (p=0; p<RtsFlags.GranFlags.proc; p++) {
- fprintf(stderr,", PE %d: (hd=%p,tl=%p)",
- run_queue_hds[p], run_queue_tls[p]);
- }
-}
-
-void
-printThreadQ(StgTSO *tso) { G_THREADQ(tso, 0); };
-
-void
-printSparkQ(rtsSpark *spark) { G_SPARKQ(spark, 0); };
-
-void
-printThreadQ_verbose(StgTSO *tso) { G_THREADQ(tso, 1); };
-
-void
-printSparkQ_verbose(rtsSpark *spark) { G_SPARKQ(spark, 1); };
-
-/* Shorthand for some of ADRs debugging functions */
-
-#endif /* GRAN && GRAN_CHECK*/
-
-#if 0
-void
-DEBUG_PRINT_NODE(node)
-StgPtr node;
-{
- W_ info_ptr = INFO_PTR(node);
- StgInt size = 0, ptrs = 0, i, vhs = 0;
- char info_type[80];
-
- info_hdr_type(info_ptr, info_type);
-
- size_and_ptrs(node,&size,&ptrs);
- vhs = var_hdr_size(node);
-
- fprintf(stderr,"Node: 0x%lx", (W_) node);
-
-#if defined(PAR)
- fprintf(stderr," [GA: 0x%lx]",GA(node));
-#endif
-
-#if defined(PROFILING)
- fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
-#endif
-
-#if defined(GRAN)
- fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
-#endif
-
- fprintf(stderr," IP: 0x%lx (%s), size %ld, %ld ptrs\n",
- info_ptr,info_type,size,ptrs);
-
- /* For now, we ignore the variable header */
-
- for(i=0; i < size; ++i)
- {
- if(i == 0)
- fprintf(stderr,"Data: ");
-
- else if(i % 6 == 0)
- fprintf(stderr,"\n ");
-
- if(i < ptrs)
- fprintf(stderr," 0x%lx[P]",*(node+_HS+vhs+i));
- else
- fprintf(stderr," %lu[D]",*(node+_HS+vhs+i));
- }
- fprintf(stderr, "\n");
-}
-
-
-#define INFO_MASK 0x80000000
-
-void
-DEBUG_TREE(node)
-StgPtr node;
-{
- W_ size = 0, ptrs = 0, i, vhs = 0;
-
- /* Don't print cycles */
- if((INFO_PTR(node) & INFO_MASK) != 0)
- return;
-
- size_and_ptrs(node,&size,&ptrs);
- vhs = var_hdr_size(node);
-
- DEBUG_PRINT_NODE(node);
- fprintf(stderr, "\n");
-
- /* Mark the node -- may be dangerous */
- INFO_PTR(node) |= INFO_MASK;
-
- for(i = 0; i < ptrs; ++i)
- DEBUG_TREE((StgPtr)node[i+vhs+_HS]);
-
- /* Unmark the node */
- INFO_PTR(node) &= ~INFO_MASK;
-}
-
-
-void
-DEBUG_INFO_TABLE(node)
-StgPtr node;
-{
- W_ info_ptr = INFO_PTR(node);
- char *iStgPtrtype = info_hdr_type(info_ptr);
-
- fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
- iStgPtrtype,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
-#if defined(PAR)
- fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
-#endif
-
-#if defined(PROFILING)
- fprintf(stderr,"Cost Centre (?): 0x%lx\n",INFO_CAT(info_ptr));
-#endif
-
-#if defined(_INFO_COPYING)
- fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
- INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
-#endif
-
-#if defined(_INFO_COMPACTING)
- fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
- (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
- fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t",
- (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
-#if 0 /* avoid INFO_TYPE */
- if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
- fprintf(stderr,"plus specialised code\n");
- else
- fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
-#endif /* 0 */
-#endif /* _INFO_COMPACTING */
-}
-#endif /* 0 */
-
-//@node Printing info type, Printing Packet Contents, Shortcuts, Debugging routines for GranSim and GUM
-//@subsection Printing info type
-
-char *
-display_info_type(closure, str)
-StgClosure *closure;
-char *str;
-{
- strcpy(str,"");
- if ( closure_HNF(closure) )
- strcat(str,"|_HNF ");
- else if ( closure_BITMAP(closure) )
- strcat(str,"|_BTM");
- else if ( !closure_SHOULD_SPARK(closure) )
- strcat(str,"|_NS");
- else if ( closure_STATIC(closure) )
- strcat(str,"|_STA");
- else if ( closure_THUNK(closure) )
- strcat(str,"|_THU");
- else if ( closure_MUTABLE(closure) )
- strcat(str,"|_MUT");
- else if ( closure_UNPOINTED(closure) )
- strcat(str,"|_UPT");
- else if ( closure_SRT(closure) )
- strcat(str,"|_SRT");
-
- return(str);
-}
-
-/*
- PrintPacket is in Pack.c because it makes use of closure queues
-*/
-
-#if defined(GRAN) || defined(PAR)
-
-/*
- Print graph rooted at q. The structure of this recursive printing routine
- should be the same as in the graph traversals when packing a graph in
- GUM. Thus, it demonstrates the structure of such a generic graph
- traversal, and in particular, how to extract pointer and non-pointer info
- from the multitude of different heap objects available.
-
- {evacuate}Daq ngoqvam nIHlu'pu'!!
-*/
-
-void
-PrintGraph(StgClosure *p, int indent_level)
-{
- void PrintGraph_(StgClosure *p, int indent_level);
-
- ASSERT(tmpClosureTable==NULL);
-
- /* init hash table */
- tmpClosureTable = allocHashTable();
-
- /* now do the real work */
- PrintGraph_(p, indent_level);
-
- /* nuke hash table */
- freeHashTable(tmpClosureTable, NULL);
- tmpClosureTable = NULL;
-}
-
-/*
- This is the actual worker functions.
- All recursive calls should be made to this function.
-*/
-void
-PrintGraph_(StgClosure *p, int indent_level)
-{
- StgPtr x, q;
- rtsBool printed = rtsFalse;
- nat i, j;
- const StgInfoTable *info;
-
- /* check whether we have met this node already to break cycles */
- if (lookupHashTable(tmpClosureTable, (StgWord)p)) { // ie. already touched
- /* indentation */
- for (j=0; j<indent_level; j++)
- fputs(" ", stderr);
-
- fprintf(stderr, "#### cylce to %p", p);
- return;
- }
-
- /* record that we are processing this closure */
- insertHashTable(tmpClosureTable, (StgWord) p, (void *)rtsTrue/*non-NULL*/);
-
- q = p; /* save ptr to object */
-
- /* indentation */
- for (j=0; j<indent_level; j++)
- fputs(" ", stderr);
-
- ASSERT(p!=(StgClosure*)NULL);
- ASSERT(LOOKS_LIKE_STATIC(p) ||
- LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p)) ||
- IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p)));
-
- printClosure(p); // prints contents of this one closure
-
- /* indentation */
- for (j=0; j<indent_level; j++)
- fputs(" ", stderr);
-
- info = get_itbl((StgClosure *)p);
- /* the rest of this fct recursively traverses the graph */
- switch (info -> type) {
-
- case BCO:
- {
- StgBCO* bco = stgCast(StgBCO*,p);
- nat i;
- fprintf(stderr, "BCO (%p)\n", p);
- /*
- for (i = 0; i < bco->n_ptrs; i++) {
- // bcoConstCPtr(bco,i) =
- PrintGraph_(bcoConstCPtr(bco,i), indent_level+1);
- }
- */
- // p += bco_sizeW(bco);
- break;
- }
-
- case MVAR:
- /* treat MVars specially, because we don't want to PrintGraph the
- * mut_link field in the middle of the closure.
- */
- {
- StgMVar *mvar = ((StgMVar *)p);
- // evac_gen = 0;
- fprintf(stderr, "MVAR (%p) with 3 pointers (head, tail, value)\n", p);
- // (StgClosure *)mvar->head =
- PrintGraph_((StgClosure *)mvar->head, indent_level+1);
- // (StgClosure *)mvar->tail =
- PrintGraph_((StgClosure *)mvar->tail, indent_level+1);
- //(StgClosure *)mvar->value =
- PrintGraph_((StgClosure *)mvar->value, indent_level+1);
- // p += sizeofW(StgMVar);
- // evac_gen = saved_evac_gen;
- break;
- }
-
- case THUNK_2_0:
- if (!printed) {
- fprintf(stderr, "THUNK_2_0 (%p) with 2 pointers\n", p);
- printed = rtsTrue;
- }
- case FUN_2_0:
- if (!printed) {
- fprintf(stderr, "FUN_2_0 (%p) with 2 pointers\n", p);
- printed = rtsTrue;
- }
- // scavenge_srt(info);
- case CONSTR_2_0:
- if (!printed) {
- fprintf(stderr, "CONSTR_2_0 (%p) with 2 pointers\n", p);
- printed = rtsTrue;
- }
- // ((StgClosure *)p)->payload[0] =
- PrintGraph_(((StgClosure *)p)->payload[0],
- indent_level+1);
- // ((StgClosure *)p)->payload[1] =
- PrintGraph_(((StgClosure *)p)->payload[1],
- indent_level+1);
- // p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_1_0:
- // scavenge_srt(info);
- fprintf(stderr, "THUNK_1_0 (%p) with 1 pointer\n", p);
- // ((StgClosure *)p)->payload[0] =
- PrintGraph_(((StgClosure *)p)->payload[0],
- indent_level+1);
- // p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
- break;
-
- case FUN_1_0:
- if (!printed) {
- fprintf(stderr, "FUN_1_0 (%p) with 1 pointer\n", p);
- printed = rtsTrue;
- }
- // scavenge_srt(info);
- case CONSTR_1_0:
- if (!printed) {
- fprintf(stderr, "CONSTR_2_0 (%p) with 2 pointers\n", p);
- printed = rtsTrue;
- }
- // ((StgClosure *)p)->payload[0] =
- PrintGraph_(((StgClosure *)p)->payload[0],
- indent_level+1);
- // p += sizeofW(StgHeader) + 1;
- break;
-
- case THUNK_0_1:
- fprintf(stderr, "THUNK_0_1 (%p) with 0 pointers\n", p);
- // scavenge_srt(info);
- // p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
- break;
-
- case FUN_0_1:
- fprintf(stderr, "FUN_0_1 (%p) with 0 pointers\n", p);
- //scavenge_srt(info);
- case CONSTR_0_1:
- fprintf(stderr, "CONSTR_0_1 (%p) with 0 pointers\n", p);
- //p += sizeofW(StgHeader) + 1;
- break;
-
- case THUNK_0_2:
- if (!printed) {
- fprintf(stderr, "THUNK_0_2 (%p) with 0 pointers\n", p);
- printed = rtsTrue;
- }
- case FUN_0_2:
- if (!printed) {
- fprintf(stderr, "FUN_0_2 (%p) with 0 pointers\n", p);
- printed = rtsTrue;
- }
- // scavenge_srt(info);
- case CONSTR_0_2:
- if (!printed) {
- fprintf(stderr, "CONSTR_0_2 (%p) with 0 pointers\n", p);
- printed = rtsTrue;
- }
- // p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_1_1:
- if (!printed) {
- fprintf(stderr, "THUNK_1_1 (%p) with 1 pointer\n", p);
- printed = rtsTrue;
- }
- case FUN_1_1:
- if (!printed) {
- fprintf(stderr, "FUN_1_1 (%p) with 1 pointer\n", p);
- printed = rtsTrue;
- }
- // scavenge_srt(info);
- case CONSTR_1_1:
- if (!printed) {
- fprintf(stderr, "CONSTR_1_1 (%p) with 1 pointer\n", p);
- printed = rtsTrue;
- }
- // ((StgClosure *)p)->payload[0] =
- PrintGraph_(((StgClosure *)p)->payload[0],
- indent_level+1);
- // p += sizeofW(StgHeader) + 2;
- break;
-
- case FUN:
- if (!printed) {
- fprintf(stderr, "FUN (%p) with %d pointers\n", p, info->layout.payload.ptrs);
- printed = rtsTrue;
- }
- /* fall through */
-
- case THUNK:
- if (!printed) {
- fprintf(stderr, "THUNK (%p) with %d pointers\n", p, info->layout.payload.ptrs);
- printed = rtsTrue;
- }
- // scavenge_srt(info);
- /* fall through */
-
- case CONSTR:
- if (!printed) {
- fprintf(stderr, "CONSTR (%p) with %d pointers\n", p, info->layout.payload.ptrs);
- printed = rtsTrue;
- }
- /* basically same as loop in STABLE_NAME case */
- for (i=0; i<info->layout.payload.ptrs; i++)
- PrintGraph_(((StgClosure *)p)->payload[i],
- indent_level+1);
- break;
- /* NOT fall through */
-
- case WEAK:
- if (!printed) {
- fprintf(stderr, "WEAK (%p) with %d pointers\n", p, info->layout.payload.ptrs);
- printed = rtsTrue;
- }
- /* fall through */
-
- case FOREIGN:
- if (!printed) {
- fprintf(stderr, "FOREIGN (%p) with %d pointers\n", p, info->layout.payload.ptrs);
- printed = rtsTrue;
- }
- /* fall through */
-
- case STABLE_NAME:
- {
- StgPtr end;
-
- if (!printed) {
- fprintf(stderr, "STABLE_NAME (%p) with %d pointers (not followed!)\n",
- p, info->layout.payload.ptrs);
- printed = rtsTrue;
- }
- end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
- for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
- // (StgClosure *)*p =
- //PrintGraph_((StgClosure *)*p, indent_level+1);
- fprintf(stderr, ", %p", *p);
- }
- //fputs("\n", stderr);
- // p += info->layout.payload.nptrs;
- break;
- }
-
- case IND_PERM:
- //if (step->gen->no != 0) {
- // SET_INFO(((StgClosure *)p), &IND_OLDGEN_PERM_info);
- //}
- if (!printed) {
- fprintf(stderr, "IND_PERM (%p) with indirection to\n",
- p, ((StgIndOldGen *)p)->indirectee);
- printed = rtsTrue;
- }
- /* fall through */
-
- case IND_OLDGEN_PERM:
- if (!printed) {
- fprintf(stderr, "IND_OLDGEN_PERM (%p) with indirection to %p\n",
- p, ((StgIndOldGen *)p)->indirectee);
- printed = rtsTrue;
- }
- // ((StgIndOldGen *)p)->indirectee =
- PrintGraph_(((StgIndOldGen *)p)->indirectee,
- indent_level+1);
- //if (failed_to_evac) {
- // failed_to_evac = rtsFalse;
- // recordOldToNewPtrs((StgMutClosure *)p);
- //}
- // p += sizeofW(StgIndOldGen);
- break;
-
- case MUT_VAR:
- /* ignore MUT_CONSs */
- fprintf(stderr, "MUT_VAR (%p) pointing to %p\n", p, ((StgMutVar *)p)->var);
- if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
- //evac_gen = 0;
- PrintGraph_(((StgMutVar *)p)->var, indent_level+1);
- //evac_gen = saved_evac_gen;
- }
- //p += sizeofW(StgMutVar);
- break;
-
- case CAF_BLACKHOLE:
- if (!printed) {
- fprintf(stderr, "CAF_BLACKHOLE (%p) with 0 pointers\n", p);
- printed = rtsTrue;
- }
- case SE_CAF_BLACKHOLE:
- if (!printed) {
- fprintf(stderr, "SE_CAF_BLACKHOLE (%p) with 0 pointers\n", p);
- printed = rtsTrue;
- }
- case SE_BLACKHOLE:
- if (!printed) {
- fprintf(stderr, "SE_BLACKHOLE (%p) with 0 pointers\n", p);
- printed = rtsTrue;
- }
- case BLACKHOLE:
- if (!printed) {
- fprintf(stderr, "BLACKHOLE (%p) with 0 pointers\n", p);
- printed = rtsTrue;
- }
- //p += BLACKHOLE_sizeW();
- break;
-
- case BLACKHOLE_BQ:
- {
- StgBlockingQueue *bh = (StgBlockingQueue *)p;
- // (StgClosure *)bh->blocking_queue =
- fprintf(stderr, "BLACKHOLE_BQ (%p) pointing to %p\n",
- p, (StgClosure *)bh->blocking_queue);
- PrintGraph_((StgClosure *)bh->blocking_queue, indent_level+1);
- //if (failed_to_evac) {
- // failed_to_evac = rtsFalse;
- // recordMutable((StgMutClosure *)bh);
- //}
- // p += BLACKHOLE_sizeW();
- break;
- }
-
- case THUNK_SELECTOR:
- {
- StgSelector *s = (StgSelector *)p;
- fprintf(stderr, "THUNK_SELECTOR (%p) pointing to %p\n",
- p, s->selectee);
- PrintGraph_(s->selectee, indent_level+1);
- // p += THUNK_SELECTOR_sizeW();
- break;
- }
-
- case IND:
- fprintf(stderr, "IND (%p) pointing to %p\n", p, ((StgInd*)p)->indirectee);
- PrintGraph_(((StgInd*)p)->indirectee, indent_level+1);
- break;
-
- case IND_OLDGEN:
- fprintf(stderr, "IND_OLDGEN (%p) pointing to %p\n",
- p, ((StgIndOldGen*)p)->indirectee);
- PrintGraph_(((StgIndOldGen*)p)->indirectee, indent_level+1);
- break;
-
- case CONSTR_INTLIKE:
- fprintf(stderr, "CONSTR_INTLIKE (%p) with 0 pointers\n", p);
- break;
- case CONSTR_CHARLIKE:
- fprintf(stderr, "CONSTR_CHARLIKE (%p) with 0 pointers\n", p);
- break;
- case CONSTR_STATIC:
- fprintf(stderr, "CONSTR_STATIC (%p) with 0 pointers\n", p);
- break;
- case CONSTR_NOCAF_STATIC:
- fprintf(stderr, "CONSTR_NOCAF_STATIC (%p) with 0 pointers\n", p);
- break;
- case THUNK_STATIC:
- fprintf(stderr, "THUNK_STATIC (%p) with 0 pointers\n", p);
- break;
- case FUN_STATIC:
- fprintf(stderr, "FUN_STATIC (%p) with 0 pointers\n", p);
- break;
- case IND_STATIC:
- fprintf(stderr, "IND_STATIC (%p) with 0 pointers\n", p);
- break;
-
- case RET_BCO:
- fprintf(stderr, "RET_BCO (%p) with 0 pointers\n", p);
- break;
- case RET_SMALL:
- fprintf(stderr, "RET_SMALL (%p) with 0 pointers\n", p);
- break;
- case RET_VEC_SMALL:
- fprintf(stderr, "RET_VEC_SMALL (%p) with 0 pointers\n", p);
- break;
- case RET_BIG:
- fprintf(stderr, "RET_BIG (%p) with 0 pointers\n", p);
- break;
- case RET_VEC_BIG:
- fprintf(stderr, "RET_VEC_BIG (%p) with 0 pointers\n", p);
- break;
- case RET_DYN:
- fprintf(stderr, "RET_DYN (%p) with 0 pointers\n", p);
- break;
- case UPDATE_FRAME:
- fprintf(stderr, "UPDATE_FRAME (%p) with 0 pointers\n", p);
- break;
- case STOP_FRAME:
- fprintf(stderr, "STOP_FRAME (%p) with 0 pointers\n", p);
- break;
- case CATCH_FRAME:
- fprintf(stderr, "CATCH_FRAME (%p) with 0 pointers\n", p);
- break;
- case SEQ_FRAME:
- fprintf(stderr, "SEQ_FRAME (%p) with 0 pointers\n", p);
- break;
-
- case AP_UPD: /* same as PAPs */
- fprintf(stderr, "AP_UPD (%p) with 0 pointers\n", p);
- case PAP:
- /* Treat a PAP just like a section of stack, not forgetting to
- * PrintGraph_ the function pointer too...
- */
- {
- StgPAP* pap = stgCast(StgPAP*,p);
-
- fprintf(stderr, "PAP (%p) pointing to %p\n", p, pap->fun);
- // pap->fun =
- //PrintGraph_(pap->fun, indent_level+1);
- //scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
- //p += pap_sizeW(pap);
- break;
- }
-
- case ARR_WORDS:
- /* an array of (non-mutable) words */
- fprintf(stderr, "ARR_WORDS (%p) of %d non-ptrs (maybe a string?)\n",
- p, ((StgArrWords *)q)->words);
- break;
-
- case MUT_ARR_PTRS:
- /* follow everything */
- {
- StgPtr next;
-
- fprintf(stderr, "MUT_ARR_PTRS (%p) with %d pointers (not followed)\n",
- p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p));
- // evac_gen = 0; /* repeatedly mutable */
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- // (StgClosure *)*p =
- // PrintGraph_((StgClosure *)*p, indent_level+1);
- fprintf(stderr, ", %p", *p);
- }
- fputs("\n", stderr);
- //evac_gen = saved_evac_gen;
- break;
- }
-
- case MUT_ARR_PTRS_FROZEN:
- /* follow everything */
- {
- StgPtr start = p, next;
-
- fprintf(stderr, "MUT_ARR_PTRS (%p) with %d pointers (not followed)",
- p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p));
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- // (StgClosure *)*p =
- // PrintGraph_((StgClosure *)*p, indent_level+1);
- fprintf(stderr, ", %p", *p);
- }
- fputs("\n", stderr);
- //if (failed_to_evac) {
- /* we can do this easier... */
- // recordMutable((StgMutClosure *)start);
- // failed_to_evac = rtsFalse;
- //}
- break;
- }
-
- case TSO:
- {
- StgTSO *tso;
-
- tso = (StgTSO *)p;
- fprintf(stderr, "TSO (%p) with link field %p\n", p, (StgClosure *)tso->link);
- // evac_gen = 0;
- /* chase the link field for any TSOs on the same queue */
- // (StgClosure *)tso->link =
- PrintGraph_((StgClosure *)tso->link, indent_level+1);
- //if (tso->blocked_on) {
- // tso->blocked_on = PrintGraph_(tso->blocked_on);
- //}
- /* scavenge this thread's stack */
- //scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
- //evac_gen = saved_evac_gen;
- //p += tso_sizeW(tso);
- break;
- }
-
-#if defined(GRAN) || defined(PAR)
- case RBH:
- {
- StgInfoTable *rip = REVERT_INFOPTR(get_itbl(p));
- //if (LOOKS_LIKE_GHC_INFO(rip))
- // fprintf(stderr, "RBH (%p) with 0 pointers (reverted type=%s)\n",
- // p, info_type_by_ip(rip));
- //else
- fprintf(stderr, "RBH (%p) with 0 pointers (reverted IP=%x)\n",
- p, rip);
- }
- break;
-#endif
-#if defined(PAR)
- case BLOCKED_FETCH:
- fprintf(stderr, "BLOCKED_FETCH (%p) with 0 pointers (link=%p)\n",
- p, ((StgBlockedFetch *)p)->link);
- break;
- case FETCH_ME:
- fprintf(stderr, "FETCH_ME (%p) with 0 pointers\n", p);
- break;
- case FETCH_ME_BQ:
- fprintf(stderr, "FETCH_ME_BQ (%p) with 0 pointers (blocking_queue=%p)\n",
- p, ((StgFetchMeBlockingQueue *)p)->blocking_queue);
- break;
-#endif
-
-#ifdef DIST
- case REMOTE_REF:
- fprintf(stderr, "REMOTE_REF (%p) with 0 pointers\n", p);
- break;
-#endif
-
- case EVACUATED:
- fprintf(stderr, "EVACUATED (%p) with 0 pointers (evacuee=%p)\n",
- p, ((StgEvacuated *)p)->evacuee);
- break;
-
- default:
- barf("PrintGraph_: unknown closure %d (%s)",
- info -> type, info_type(info));
- }
-
- /* If we didn't manage to promote all the objects pointed to by
- * the current object, then we have to designate this object as
- * mutable (because it contains old-to-new generation pointers).
- */
- //if (failed_to_evac) {
- // mkMutCons((StgClosure *)q, &generations[evac_gen]);
- // failed_to_evac = rtsFalse;
- //}
-}
-
-# if defined(PAR)
-/*
- Generate a finger-print for a graph.
- A finger-print is a string, with each char representing one node;
- depth-first traversal
-*/
-
-void
-GraphFingerPrint(StgClosure *p, char *finger_print)
-{
- void GraphFingerPrint_(StgClosure *p, char *finger_print);
-
- ASSERT(tmpClosureTable==NULL);
- ASSERT(strlen(finger_print)==0);
-
- /* init hash table */
- tmpClosureTable = allocHashTable();
-
- /* now do the real work */
- GraphFingerPrint_(p, finger_print);
-
- /* nuke hash table */
- freeHashTable(tmpClosureTable, NULL);
- tmpClosureTable = NULL;
-}
-
-/*
- This is the actual worker functions.
- All recursive calls should be made to this function.
-*/
-void
-GraphFingerPrint_(StgClosure *p, char *finger_print)
-{
- StgPtr x, q;
- rtsBool printed = rtsFalse;
- nat i, j, len;
- const StgInfoTable *info;
-
- q = p; /* save ptr to object */
- len = strlen(finger_print);
- ASSERT(len<=MAX_FINGER_PRINT_LEN);
- /* at most 7 chars for this node (I think) */
- if (len+7>=MAX_FINGER_PRINT_LEN)
- return;
-
- /* check whether we have met this node already to break cycles */
- if (lookupHashTable(tmpClosureTable, (StgWord)p)) { // ie. already touched
- strcat(finger_print, "#");
- return;
- }
-
- /* record that we are processing this closure */
- insertHashTable(tmpClosureTable, (StgWord) p, (void *)rtsTrue/*non-NULL*/);
-
- ASSERT(p!=(StgClosure*)NULL);
- ASSERT(LOOKS_LIKE_STATIC(p) ||
- LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p)) ||
- IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p)));
-
- info = get_itbl((StgClosure *)p);
- // append char for this node
- finger_print[len] = finger_print_char[info->type]; finger_print[len+1] = '\0';
- /* the rest of this fct recursively traverses the graph */
- switch (info -> type) {
-
- case BCO:
- {
- StgBCO* bco = stgCast(StgBCO*,p);
- nat i;
- //%% fprintf(stderr, "BCO (%p) with %d pointers\n", p, bco->n_ptrs);
- /*
- for (i = 0; i < bco->n_ptrs; i++) {
- // bcoConstCPtr(bco,i) =
- GraphFingerPrint_(bcoConstCPtr(bco,i), finger_print);
- }
- */
- // p += bco_sizeW(bco);
- break;
- }
-
- case MVAR:
- break;
-
- case THUNK_2_0:
- case FUN_2_0:
- case CONSTR_2_0:
- // append char for this node
- strcat(finger_print, "22(");
- GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
- GraphFingerPrint_(((StgClosure *)p)->payload[1], finger_print);
- if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
- strcat(finger_print, ")");
- break;
-
- case THUNK_1_0:
- case FUN_1_0:
- case CONSTR_1_0:
- // append char for this node
- strcat(finger_print, "12(");
- GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
- if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
- strcat(finger_print, ")");
- break;
-
- case THUNK_0_1:
- case FUN_0_1:
- case CONSTR_0_1:
- // append char for this node
- strcat(finger_print, "01");
- break;
-
- case THUNK_0_2:
- case FUN_0_2:
- case CONSTR_0_2:
- // append char for this node
- strcat(finger_print, "02");
- break;
-
- case THUNK_1_1:
- case FUN_1_1:
- case CONSTR_1_1:
- // append char for this node
- strcat(finger_print, "11(");
- GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
- if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
- strcat(finger_print, ")");
- break;
-
- case FUN:
- case THUNK:
- case CONSTR:
- /* basically same as loop in STABLE_NAME case */
- {
- char str[6];
- sprintf(str,"%d?(",info->layout.payload.ptrs);
- strcat(finger_print,str);
- for (i=0; i<info->layout.payload.ptrs; i++)
- GraphFingerPrint_(((StgClosure *)p)->payload[i], finger_print);
- if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
- strcat(finger_print, ")");
- }
- break;
-
- case WEAK:
- case FOREIGN:
- case STABLE_NAME:
- {
- StgPtr end;
- char str[6];
- sprintf(str,"%d?", info->layout.payload.ptrs);
- strcat(finger_print,str);
-
- //end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
- //for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
- // GraphFingerPrint_((StgClosure *)*p, finger_print);
- //}
- break;
- }
-
- case IND_PERM:
- case IND_OLDGEN_PERM:
- GraphFingerPrint_(((StgIndOldGen *)p)->indirectee, finger_print);
- break;
-
- case MUT_VAR:
- /* ignore MUT_CONSs */
- if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
- GraphFingerPrint_(((StgMutVar *)p)->var, finger_print);
- }
- break;
-
- case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
- case BLACKHOLE:
- break;
-
- case BLACKHOLE_BQ:
- {
- StgBlockingQueue *bh = (StgBlockingQueue *)p;
- // GraphFingerPrint_((StgClosure *)bh->blocking_queue, finger_print);
- break;
- }
-
- case THUNK_SELECTOR:
- {
- StgSelector *s = (StgSelector *)p;
- GraphFingerPrint_(s->selectee, finger_print);
- break;
- }
-
- case IND:
- GraphFingerPrint_(((StgInd*)p)->indirectee, finger_print);
- break;
-
- case IND_OLDGEN:
- GraphFingerPrint_(((StgIndOldGen*)p)->indirectee, finger_print);
- break;
-
- case IND_STATIC:
- GraphFingerPrint_(((StgIndOldGen*)p)->indirectee, finger_print);
- break;
-
- case CONSTR_INTLIKE:
- case CONSTR_CHARLIKE:
- case CONSTR_STATIC:
- case CONSTR_NOCAF_STATIC:
- case THUNK_STATIC:
- case FUN_STATIC:
- break;
-
- case RET_BCO:
- case RET_SMALL:
- case RET_VEC_SMALL:
- case RET_BIG:
- case RET_VEC_BIG:
- case RET_DYN:
- case UPDATE_FRAME:
- case STOP_FRAME:
- case CATCH_FRAME:
- case SEQ_FRAME:
- break;
-
- case AP_UPD: /* same as PAPs */
- case PAP:
- /* Treat a PAP just like a section of stack, not forgetting to
- * GraphFingerPrint_ the function pointer too...
- */
- {
- StgPAP* pap = stgCast(StgPAP*,p);
- char str[6];
- sprintf(str,"%d",pap->n_args);
- strcat(finger_print,str);
- //GraphFingerPrint_(pap->fun, finger_print); // ??
- break;
- }
-
- case ARR_WORDS:
- {
- char str[6];
- sprintf(str,"%d",((StgArrWords*)p)->words);
- strcat(finger_print,str);
- }
- break;
-
- case MUT_ARR_PTRS:
- /* follow everything */
- {
- char str[6];
- sprintf(str,"%d",((StgMutArrPtrs*)p)->ptrs);
- strcat(finger_print,str);
- }
- {
- StgPtr next;
- //next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- //for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- // GraphFingerPrint_((StgClosure *)*p, finger_print);
- //}
- break;
- }
-
- case MUT_ARR_PTRS_FROZEN:
- /* follow everything */
- {
- char str[6];
- sprintf(str,"%d",((StgMutArrPtrs*)p)->ptrs);
- strcat(finger_print,str);
- }
- {
- StgPtr start = p, next;
- //next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- //for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- // GraphFingerPrint_((StgClosure *)*p, finger_print);
- //}
- break;
- }
-
- case TSO:
- {
- StgTSO *tso = (StgTSO *)p;
- char str[6];
- sprintf(str,"%d",tso->id);
- strcat(finger_print,str);
- }
- //GraphFingerPrint_((StgClosure *)tso->link, indent_level+1);
- break;
-
-#if defined(GRAN) || defined(PAR)
- case RBH:
- {
- // use this
- // StgInfoTable *rip = REVERT_INFOPTR(get_itbl(p));
- }
- break;
-#endif
-#if defined(PAR)
- case BLOCKED_FETCH:
- break;
- case FETCH_ME:
- break;
- case FETCH_ME_BQ:
- break;
-#endif
-#ifdef DIST
- case REMOTE_REF:
- break;
-#endif
- case EVACUATED:
- break;
-
- default:
- barf("GraphFingerPrint_: unknown closure %d (%s)",
- info -> type, info_type(info));
- }
-
-}
-# endif /* PAR */
-
-/*
- Do a sanity check on the whole graph, down to a recursion level of level.
- Same structure as PrintGraph (nona).
-*/
-void
-checkGraph(StgClosure *p, int rec_level)
-{
- StgPtr x, q;
- nat i, j;
- const StgInfoTable *info;
-
- if (rec_level==0)
- return;
-
- q = p; /* save ptr to object */
-
- /* First, the obvious generic checks */
- ASSERT(p!=(StgClosure*)NULL);
- checkClosure(p); /* see Sanity.c for what's actually checked */
-
- info = get_itbl((StgClosure *)p);
- /* the rest of this fct recursively traverses the graph */
- switch (info -> type) {
-
- case BCO:
- {
- StgBCO* bco = stgCast(StgBCO*,p);
- nat i;
- /*
- for (i = 0; i < bco->n_ptrs; i++) {
- checkGraph(bcoConstCPtr(bco,i), rec_level-1);
- }
- */
- break;
- }
-
- case MVAR:
- /* treat MVars specially, because we don't want to PrintGraph the
- * mut_link field in the middle of the closure.
- */
- {
- StgMVar *mvar = ((StgMVar *)p);
- checkGraph((StgClosure *)mvar->head, rec_level-1);
- checkGraph((StgClosure *)mvar->tail, rec_level-1);
- checkGraph((StgClosure *)mvar->value, rec_level-1);
- break;
- }
-
- case THUNK_2_0:
- case FUN_2_0:
- case CONSTR_2_0:
- checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
- checkGraph(((StgClosure *)p)->payload[1], rec_level-1);
- break;
-
- case THUNK_1_0:
- checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
- break;
-
- case FUN_1_0:
- case CONSTR_1_0:
- checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
- break;
-
- case THUNK_0_1:
- break;
-
- case FUN_0_1:
- case CONSTR_0_1:
- break;
-
- case THUNK_0_2:
- case FUN_0_2:
- case CONSTR_0_2:
- break;
-
- case THUNK_1_1:
- case FUN_1_1:
- case CONSTR_1_1:
- checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
- break;
-
- case FUN:
- case THUNK:
- case CONSTR:
- for (i=0; i<info->layout.payload.ptrs; i++)
- checkGraph(((StgClosure *)p)->payload[i], rec_level-1);
- break;
-
- case WEAK:
- case FOREIGN:
- case STABLE_NAME:
- {
- StgPtr end;
-
- end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
- for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
- checkGraph(*(StgClosure **)p, rec_level-1);
- }
- break;
- }
-
- case IND_PERM:
- case IND_OLDGEN_PERM:
- checkGraph(((StgIndOldGen *)p)->indirectee, rec_level-1);
- break;
-
- case MUT_VAR:
- /* ignore MUT_CONSs */
- if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
- checkGraph(((StgMutVar *)p)->var, rec_level-1);
- }
- break;
-
- case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
- case BLACKHOLE:
- break;
-
- case BLACKHOLE_BQ:
- break;
-
- case THUNK_SELECTOR:
- {
- StgSelector *s = (StgSelector *)p;
- checkGraph(s->selectee, rec_level-1);
- break;
- }
-
- case IND:
- checkGraph(((StgInd*)p)->indirectee, rec_level-1);
- break;
-
- case IND_OLDGEN:
- checkGraph(((StgIndOldGen*)p)->indirectee, rec_level-1);
- break;
-
- case CONSTR_INTLIKE:
- break;
- case CONSTR_CHARLIKE:
- break;
- case CONSTR_STATIC:
- break;
- case CONSTR_NOCAF_STATIC:
- break;
- case THUNK_STATIC:
- break;
- case FUN_STATIC:
- break;
- case IND_STATIC:
- break;
-
- case RET_BCO:
- break;
- case RET_SMALL:
- break;
- case RET_VEC_SMALL:
- break;
- case RET_BIG:
- break;
- case RET_VEC_BIG:
- break;
- case RET_DYN:
- break;
- case UPDATE_FRAME:
- break;
- case STOP_FRAME:
- break;
- case CATCH_FRAME:
- break;
- case SEQ_FRAME:
- break;
-
- case AP_UPD: /* same as PAPs */
- case PAP:
- /* Treat a PAP just like a section of stack, not forgetting to
- * checkGraph the function pointer too...
- */
- {
- StgPAP* pap = stgCast(StgPAP*,p);
-
- checkGraph(pap->fun, rec_level-1);
- break;
- }
-
- case ARR_WORDS:
- break;
-
- case MUT_ARR_PTRS:
- /* follow everything */
- {
- StgPtr next;
-
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- checkGraph(*(StgClosure **)p, rec_level-1);
- }
- break;
- }
-
- case MUT_ARR_PTRS_FROZEN:
- /* follow everything */
- {
- StgPtr start = p, next;
-
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- checkGraph(*(StgClosure **)p, rec_level-1);
- }
- break;
- }
-
- case TSO:
- {
- StgTSO *tso;
-
- tso = (StgTSO *)p;
- checkGraph((StgClosure *)tso->link, rec_level-1);
- break;
- }
-
-#if defined(GRAN) || defined(PAR)
- case RBH:
- break;
-#endif
-#if defined(PAR)
- case BLOCKED_FETCH:
- break;
- case FETCH_ME:
- break;
- case FETCH_ME_BQ:
- break;
-#endif
- case EVACUATED:
- barf("checkGraph: found EVACUATED closure %p (%s)",
- p, info_type(p));
- break;
-
- default:
- }
-}
-
-#endif /* GRAN */
-
-#endif /* GRAN || PAR */
-
-//@node End of File, , Printing Packet Contents, Debugging routines for GranSim and GUM
-//@subsection End of File
projects / ghc-hetmet.git / blobdiff