Improve error reporting for 'deriving' (Trac #2604)
[ghc-hetmet.git] / rts / parallel / ParallelDebug.c
1 /*
2   Time-stamp: <Sun Mar 18 2001 19:32:56 Stardate: [-30]6349.07 hwloidl>
3
4   Various debugging routines for GranSim and GUM
5 */
6
7 #if defined(DEBUG) && (defined(GRAN) || defined(PAR))        /* whole file */
8
9 //@node Debugging routines for GranSim and GUM, , ,
10 //@section Debugging routines for GranSim and GUM
11
12 //@menu
13 //* Includes::                  
14 //* Constants and Variables::   
15 //* Closures::                  
16 //* Threads::                   
17 //* Events::                    
18 //* Sparks::                    
19 //* Processors::                
20 //* Shortcuts::                 
21 //* Printing info type::        
22 //* Printing Pack:et Contents:: 
23 //* End of File::               
24 //@end menu
25 //*/
26
27 //@node Includes, Prototypes, Debugging routines for GranSim and GUM, Debugging routines for GranSim and GUM
28 //@subsection Includes
29
30 #include "Rts.h"
31 #include "RtsFlags.h"
32 #include "GranSimRts.h"
33 #include "ParallelRts.h"
34 #include "StgMiscClosures.h"
35 #include "Printer.h"
36 # if defined(DEBUG)
37 # include "Hash.h" 
38 # include "Storage.h"
39 # include "ParallelDebug.h"
40 # endif
41
42 //@node Prototypes, Constants and Variables, Includes, Debugging routines for GranSim and GUM
43 //@subsection Prototypes
44 /*
45 rtsBool  isOffset(globalAddr *ga);
46 rtsBool  isFixed(globalAddr *ga);
47 */
48 //@node Constants and Variables, Closures, Prototypes, Debugging routines for GranSim and GUM
49 //@subsection Constants and Variables
50
51 static HashTable *tmpClosureTable;  // used in GraphFingerPrint and PrintGraph
52
53 #if defined(PAR)
54 static char finger_print_char[] = {
55  '/',  /* INVALID_OBJECT          0 */
56  'C', /* CONSTR                  1 */
57  'C', /*        CONSTR_1_0              2 */
58  'C', /*        CONSTR_0_1              3 */
59  'C', /*        CONSTR_2_0              4 */
60  'C', /*        CONSTR_1_1              5 */
61  'C', /*        CONSTR_0_2              6 */
62  'I', /* CONSTR_INTLIKE         7  */
63  'I', /* CONSTR_CHARLIKE                8  */
64  'S', /* CONSTR_STATIC          9  */
65  'S', /* CONSTR_NOCAF_STATIC     10 */
66  'F', /* FUN                    11 */
67  'F', /*        FUN_1_0                 12 */
68  'F', /*        FUN_0_1                 13 */
69  'F', /*        FUN_2_0                 14 */
70  'F', /*        FUN_1_1                 15 */
71  'F', /*        FUN_0_2                 16 */
72  'S', /* FUN_STATIC             17 */
73  'T', /* THUNK                  18 */
74  'T', /*        THUNK_1_0       19 */
75  'T', /*        THUNK_0_1       20 */
76  'T', /*        THUNK_2_0       21 */
77  'T', /*        THUNK_1_1       22 */
78  'T', /*        THUNK_0_2       23 */
79  'S', /* THUNK_STATIC           24 */
80  'E', /* THUNK_SELECTOR         25 */
81  'b', /* BCO                    26 */
82  'p', /* AP_UPD                 27 */
83  'p', /* PAP                    28 */
84  '_', /* IND                    29 */
85  '_', /* IND_OLDGEN             30 */
86  '_', /* IND_PERM               31 */
87  '_', /* IND_OLDGEN_PERM        32 */
88  '_', /* IND_STATIC             33 */
89  '?', /* ***unused***           34 */
90  '?', /* ***unused***           35 */
91  '^', /* RET_BCO                36 */
92  '^', /* RET_SMALL              37 */
93  '^', /* RET_VEC_SMALL          38 */
94  '^', /* RET_BIG                39 */
95  '^', /* RET_VEC_BIG            40 */
96  '^', /* RET_DYN                41 */
97  '~', /* UPDATE_FRAME           42 */
98  '~', /* CATCH_FRAME            43 */
99  '~', /* STOP_FRAME             44 */
100  '~', /* SEQ_FRAME              45 */
101  'o', /* CAF_BLACKHOLE          46 */
102  'o', /* BLACKHOLE              47 */
103  'o', /* BLACKHOLE_BQ           48 */
104  'o', /* SE_BLACKHOLE           49 */
105  'o', /* SE_CAF_BLACKHOLE       50 */
106  'm', /* MVAR                   51 */
107  'a', /* ARR_WORDS              52 */
108  'a', /* MUT_ARR_PTRS           53 */
109  'a', /* MUT_ARR_PTRS_FROZEN    54 */
110  'q', /* MUT_VAR                55 */
111  'w', /* WEAK                   56 */
112  'f', /* FOREIGN                57 */
113  's', /* STABLE_NAME            58 */
114  '@', /* TSO                    59 */
115  '#', /* BLOCKED_FETCH          60 */
116  '>', /* FETCH_ME               61 */
117  '>', /* FETCH_ME_BQ            62 */
118  '$', /* RBH                    63 */
119  'v', /* EVACUATED              64 */
120  '>' /* REMOTE_REF              65 */  
121      /* ASSERT(there are N_CLOSURE_TYPES (==66) in this arrary) */
122 };
123 #endif /* PAR */
124
125 #if defined(GRAN) && defined(GRAN_CHECK)
126 //@node Closures, Threads, Constants and Variables, Debugging routines for GranSim and GUM
127 //@subsection Closures
128
129 void
130 G_PRINT_NODE(node)
131 StgClosure* node;
132 {
133    StgInfoTable *info_ptr;
134    StgTSO* bqe;
135    nat size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0;
136    char info_hdr_ty[80], info_ty[80];
137
138    if (node==NULL) {
139      fprintf(stderr,"NULL\n");
140      return;
141    } else if (node==END_TSO_QUEUE) {
142      fprintf(stderr,"END_TSO_QUEUE\n");
143      return;
144    }
145    /* size_and_ptrs(node,&size,&ptrs); */
146    info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_hdr_ty);
147
148    /* vhs = var_hdr_size(node); */
149    display_info_type(info_ptr,info_ty);
150
151    fprintf(stderr,"Node: 0x%lx", node);
152
153 #if defined(PAR)
154    fprintf(stderr," [GA: 0x%lx]",GA(node));
155 #endif
156
157 #if defined(USE_COST_CENTRES)
158    fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
159 #endif
160
161 #if defined(GRAN)
162    fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
163 #endif
164
165    if (info_ptr->type==TSO) 
166      fprintf(stderr," TSO: 0x%lx (%x) IP: 0x%lx (%s), type %s \n     ",
167              (StgTSO*)node, ((StgTSO*)node)->id, info_ptr, info_hdr_ty, info_ty);
168    else
169      fprintf(stderr," IP: 0x%lx (%s), type %s \n       VHS: %d, size: %ld, ptrs:%ld, nonptrs:  %ld\n     ",
170              info_ptr,info_hdr_ty,info_ty,vhs,size,ptrs,nonptrs);
171
172    /* For now, we ignore the variable header */
173
174    fprintf(stderr," Ptrs: ");
175    for(i=0; i < ptrs; ++i)
176      {
177      if ( (i+1) % 6 == 0)
178        fprintf(stderr,"\n      ");
179      fprintf(stderr," 0x%lx[P]",node->payload[i]);
180      };
181
182    fprintf(stderr," Data: ");
183    for(i=0; i < nonptrs; ++i)
184      {
185        if( (i+1) % 6 == 0)
186          fprintf(stderr,"\n      ");
187        fprintf(stderr," %lu[D]",node->payload[ptrs+i]);
188      }
189    fprintf(stderr, "\n");
190
191
192    switch (info_ptr->type)
193     {
194      case TSO: 
195       fprintf(stderr,"\n TSO_LINK: %#lx", 
196               ((StgTSO*)node)->link);
197       break;
198
199     case BLACKHOLE:
200     case RBH:
201       bqe = ((StgBlockingQueue*)node)->blocking_queue;
202       fprintf(stderr," BQ of %#lx: ", node);
203       G_PRINT_BQ(bqe);
204       break;
205     case FETCH_ME:
206     case FETCH_ME_BQ:
207       printf("Panic: found FETCH_ME or FETCH_ME_BQ Infotable in GrAnSim system.\n");
208       break;
209     default:
210       /* do nothing */
211     }
212 }
213
214 void
215 G_PPN(node)  /* Extracted from PrintPacket in Pack.lc */
216 StgClosure* node;
217 {
218    StgInfoTable *info ;
219    nat size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0, locn = 0;
220    char info_type[80];
221
222    /* size_and_ptrs(node,&size,&ptrs); */
223    info = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type);
224
225    if (info->type == FETCH_ME || info->type == FETCH_ME_BQ || 
226        info->type == BLACKHOLE || info->type == RBH )
227      size = ptrs = nonptrs = vhs = 0;
228
229    if (closure_THUNK(node)) {
230      if (!closure_UNPOINTED(node))
231        fputs("SHARED ", stderr);
232      else
233        fputs("UNSHARED ", stderr);
234    } 
235    if (info->type==BLACKHOLE) {
236      fputs("BLACK HOLE\n", stderr);
237    } else {
238      /* Fixed header */
239      fprintf(stderr, "(%s) FH [%#lx", info_type, node[locn++]);
240      for (i = 1; i < _HS; i++)
241        fprintf(stderr, " %#lx", node[locn++]);
242      
243      /* Variable header */
244      if (vhs > 0) {
245        fprintf(stderr, "] VH [%#lx", node->payload[0]);
246        
247        for (i = 1; i < vhs; i++)
248          fprintf(stderr, " %#lx", node->payload[i]);
249      }
250      
251      fprintf(stderr, "] PTRS %u", ptrs);
252      
253      /* Non-pointers */
254      if (nonptrs > 0) {
255        fprintf(stderr, " NPTRS [%#lx", node->payload[ptrs]);
256        
257        for (i = 1; i < nonptrs; i++)
258          fprintf(stderr, " %#lx", node->payload[ptrs+i]);
259        
260        putc(']', stderr);
261      }
262      putc('\n', stderr);
263    }
264    
265 }
266
267 #if 0
268 // ToDo: fix this!! -- HWL
269 void
270 G_INFO_TABLE(node)
271 StgClosure *node;
272 {
273   StgInfoTable *info_ptr;
274   nat size = 0, ptrs = 0, nonptrs = 0, vhs = 0;
275   char info_type[80], hdr_type[80];
276
277   info_hdr_type(info_ptr, hdr_type);
278
279   // get_itbl(node);
280   info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type);
281   fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
282                  info_type,info_ptr,(W_) ENTRY_CODE(info_ptr),
283                  size, ptrs);
284                  // INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
285
286   if (closure_THUNK(node) && !closure_UNPOINTED(node) ) {
287     fprintf(stderr,"  RBH InfoPtr: %#lx\n",
288             RBH_INFOPTR(info_ptr));
289   }
290
291 #if defined(PAR)
292   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
293 #endif
294
295 #if defined(USE_COST_CENTRES)
296   fprintf(stderr,"Cost Centre (?):       0x%lx\n",INFO_CAT(info_ptr));
297 #endif
298
299 #if defined(_INFO_COPYING)
300   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
301           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
302 #endif
303
304 #if defined(_INFO_COMPACTING)
305   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
306           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
307   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\t",
308           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
309 #if 0 /* avoid INFO_TYPE */
310   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
311     fprintf(stderr,"plus specialised code\n");
312   else
313     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
314 #endif /* 0 */
315 #endif /* _INFO_COMPACTING */
316 }
317 #endif /* 0 */
318
319 //@cindex G_PRINT_BQ
320 void
321 G_PRINT_BQ(node)
322 StgClosure* node;
323 {
324     StgInfoTable *info;
325     StgTSO *tso, *last;
326     char str[80], str0[80];
327
328     fprintf(stderr,"\n[PE %d] @ %lu BQ: ",
329                     CurrentProc,CurrentTime[CurrentProc]);
330     if ( node == (StgClosure*)NULL ) {
331       fprintf(stderr," NULL.\n");
332       return;
333     }
334     if ( node == END_TSO_QUEUE ) {
335       fprintf(stderr," _|_\n");
336       return;
337     }
338     tso = ((StgBlockingQueue*)node)->blocking_queue;
339     while (node != END_TSO_QUEUE) {
340       PEs proc;                     
341       
342       /* Find where the tso lives */
343       proc = where_is(node);
344       info = get_itbl(node);
345
346       switch (info->type) {
347           case TSO:
348             strcpy(str0,"TSO");
349             break;
350           case BLOCKED_FETCH:
351             strcpy(str0,"BLOCKED_FETCH");
352             break;
353           default:
354             strcpy(str0,"???");
355             break;
356           }
357
358       if(proc == CurrentProc)
359         fprintf(stderr," %#lx (%x) L %s,", 
360                 node, ((StgBlockingQueue*)node)->blocking_queue, str0);
361       else
362         fprintf(stderr," %#lx (%x) G (PE %d) %s,", 
363                 node, ((StgBlockingQueue*)node)->blocking_queue, proc, str0);
364
365       last = tso;
366       tso = last->link;
367     }
368     if ( tso == END_TSO_QUEUE ) 
369       fprintf(stderr," _|_\n");
370 }
371
372 //@node Threads, Events, Closures, Debugging routines for GranSim and GUM
373 //@subsection Threads
374
375 void
376 G_CURR_THREADQ(verbose) 
377 StgInt verbose;
378
379   fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
380   G_THREADQ(run_queue_hd, verbose);
381 }
382
383 void 
384 G_THREADQ(closure, verbose) 
385 StgTSO* closure;
386 StgInt verbose;
387 {
388  StgTSO* x;
389
390  fprintf(stderr,"Thread Queue: ");
391  for (x=closure; x!=END_TSO_QUEUE; x=x->link)
392    if (verbose) 
393      G_TSO(x,0);
394    else
395      fprintf(stderr," %#lx",x);
396
397  if (closure==END_TSO_QUEUE)
398    fprintf(stderr,"NIL\n");
399  else
400    fprintf(stderr,"\n");
401 }
402
403 void 
404 G_TSO(closure,verbose) 
405 StgTSO* closure;
406 StgInt verbose;
407 {
408  
409  if (closure==END_TSO_QUEUE) {
410    fprintf(stderr,"TSO at %#lx is END_TSO_QUEUE!\n");
411    return;
412  }
413
414  if ( verbose & 0x08 ) {   /* short info */
415    fprintf(stderr,"[TSO @ %#lx, PE %d]: Id: %#lx, Link: %#lx\n",
416            closure,where_is(closure),
417            closure->id,closure->link);
418    return;
419  }
420    
421  fprintf(stderr,"TSO at %#lx has the following contents:\n",
422                  closure);
423
424  fprintf(stderr,"> Id:   \t%#lx",closure->id);
425  // fprintf(stderr,"\tstate: \t%#lx",closure->state);
426  fprintf(stderr,"\twhat_next: \t%#lx",closure->what_next);
427  fprintf(stderr,"\tlink: \t%#lx\n",closure->link);
428  fprintf(stderr,"\twhy_blocked: \t%d", closure->why_blocked);
429  fprintf(stderr,"\tblock_info: \t%p\n", closure->block_info);
430  // fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
431  fprintf(stderr,">PRI: \t%#lx", closure->gran.pri);
432  fprintf(stderr,"\tMAGIC: \t%#lx %s\n", closure->gran.magic, 
433          (closure->gran.magic==TSO_MAGIC ? "it IS a TSO" : "THIS IS NO TSO!!"));
434  if ( verbose & 0x04 ) {
435    fprintf(stderr, "Stack: stack @ %#lx (stack_size: %u; max_stack_size: %u)\n", 
436            closure->stack, closure->stack_size, closure->max_stack_size);
437    fprintf(stderr, "  sp: %#lx, su: %#lx, splim: %#lx\n", 
438            closure->sp, closure->su, closure->splim);
439  }
440  // fprintf(stderr,"\n");
441  if (verbose & 0x01) {
442    // fprintf(stderr,"} LOCKED: \t%#lx",closure->locked);
443    fprintf(stderr,"} SPARKNAME: \t%#lx\n", closure->gran.sparkname);
444    fprintf(stderr,"} STARTEDAT: \t%#lx", closure->gran.startedat);
445    fprintf(stderr,"\tEXPORTED: \t%#lx\n", closure->gran.exported);
446    fprintf(stderr,"} BASICBLOCKS: \t%#lx", closure->gran.basicblocks);
447    fprintf(stderr,"\tALLOCS: \t%#lx\n", closure->gran.allocs);
448    fprintf(stderr,"} EXECTIME: \t%#lx", closure->gran.exectime);
449    fprintf(stderr,"\tFETCHTIME: \t%#lx\n", closure->gran.fetchtime);
450    fprintf(stderr,"} FETCHCOUNT: \t%#lx", closure->gran.fetchcount);
451    fprintf(stderr,"\tBLOCKTIME: \t%#lx\n", closure->gran.blocktime);
452    fprintf(stderr,"} BLOCKCOUNT: \t%#lx", closure->gran.blockcount);
453    fprintf(stderr,"\tBLOCKEDAT: \t%#lx\n", closure->gran.blockedat);
454    fprintf(stderr,"} GLOBALSPARKS:\t%#lx", closure->gran.globalsparks);
455    fprintf(stderr,"\tLOCALSPARKS:\t%#lx\n", closure->gran.localsparks);
456  }
457  if ( verbose & 0x02 ) {
458    fprintf(stderr,"BQ that starts with this TSO: ");
459    G_PRINT_BQ(closure);
460  }
461 }
462
463 //@node Events, Sparks, Threads, Debugging routines for GranSim and GUM
464 //@subsection Events
465
466 void 
467 G_EVENT(event, verbose) 
468 rtsEventQ event;
469 StgInt verbose;
470 {
471   if (verbose) {
472     print_event(event);
473   }else{
474     fprintf(stderr," %#lx",event);
475   }
476 }
477
478 void
479 G_EVENTQ(verbose)
480 StgInt verbose;
481 {
482  extern rtsEventQ EventHd;
483  rtsEventQ x;
484
485  fprintf(stderr,"RtsEventQ (hd @%#lx):\n",EventHd);
486  for (x=EventHd; x!=NULL; x=x->next) {
487    G_EVENT(x,verbose);
488  }
489  if (EventHd==NULL) 
490    fprintf(stderr,"NIL\n");
491  else
492    fprintf(stderr,"\n");
493 }
494
495 void
496 G_PE_EQ(pe,verbose)
497 PEs pe;
498 StgInt verbose;
499 {
500  extern rtsEventQ EventHd;
501  rtsEventQ x;
502
503  fprintf(stderr,"RtsEventQ (hd @%#lx):\n",EventHd);
504  for (x=EventHd; x!=NULL; x=x->next) {
505    if (x->proc==pe)
506      G_EVENT(x,verbose);
507  }
508  if (EventHd==NULL) 
509    fprintf(stderr,"NIL\n");
510  else
511    fprintf(stderr,"\n");
512 }
513
514 //@node Sparks, Processors, Events, Debugging routines for GranSim and GUM
515 //@subsection Sparks
516
517 void 
518 G_SPARK(spark, verbose) 
519 rtsSparkQ spark;
520 StgInt verbose;
521 {
522  if (spark==(rtsSpark*)NULL) {
523    belch("G_SPARK: NULL spark; aborting");
524    return;
525  }
526   if (verbose)
527     print_spark(spark);
528   else
529     fprintf(stderr," %#lx",spark);
530 }
531
532 void 
533 G_SPARKQ(spark,verbose) 
534 rtsSparkQ spark;
535 StgInt verbose;
536 {
537  rtsSparkQ x;
538
539  if (spark==(rtsSpark*)NULL) {
540    belch("G_SPARKQ: NULL spark; aborting");
541    return;
542  }
543    
544  fprintf(stderr,"RtsSparkQ (hd @%#lx):\n",spark);
545  for (x=spark; x!=NULL; x=x->next) {
546    G_SPARK(x,verbose);
547  }
548  if (spark==NULL) 
549    fprintf(stderr,"NIL\n");
550  else
551    fprintf(stderr,"\n");
552 }
553
554 void 
555 G_CURR_SPARKQ(verbose) 
556 StgInt verbose;
557 {
558   G_SPARKQ(pending_sparks_hd,verbose);
559 }
560
561 //@node Processors, Shortcuts, Sparks, Debugging routines for GranSim and GUM
562 //@subsection Processors
563
564 void 
565 G_PROC(proc,verbose)
566 StgInt proc;
567 StgInt verbose;
568
569   extern rtsEventQ EventHd;
570   extern char *proc_status_names[];
571
572   fprintf(stderr,"Status of proc %d at time %d (%#lx): %s (%s)\n",
573           proc,CurrentTime[proc],CurrentTime[proc],
574           (CurrentProc==proc)?"ACTIVE":"INACTIVE",
575           proc_status_names[procStatus[proc]]);
576   G_THREADQ(run_queue_hds[proc],verbose & 0x2);
577   if ( (CurrentProc==proc) )
578     G_TSO(CurrentTSO,1);
579
580   if (EventHd!=NULL)
581     fprintf(stderr,"Next event (%s) is on proc %d\n",
582             event_names[EventHd->evttype],EventHd->proc);
583
584   if (verbose & 0x1) {
585     fprintf(stderr,"\nREQUIRED sparks: ");
586     G_SPARKQ(pending_sparks_hds[proc],1);
587     fprintf(stderr,"\nADVISORY_sparks: ");
588     G_SPARKQ(pending_sparks_hds[proc],1);
589   }
590 }
591
592 //@node Shortcuts, Printing info type, Processors, Debugging routines for GranSim and GUM
593 //@subsection Shortcuts
594
595 /* Debug Processor */
596 void 
597 GP(proc)
598 StgInt proc;
599 { G_PROC(proc,1);
600 }
601
602 /* Debug Current Processor */
603 void
604 GCP(){ G_PROC(CurrentProc,2); }
605
606 /* Debug TSO */
607 void
608 GT(StgPtr tso){ 
609   G_TSO(tso,1);
610 }
611
612 /* Debug CurrentTSO */
613 void
614 GCT(){ 
615   fprintf(stderr,"Current Proc: %d\n",CurrentProc);
616   G_TSO(CurrentTSO,1);
617 }
618
619 /* Shorthand for debugging event queue */
620 void
621 GEQ() { G_EVENTQ(1); }
622
623 /* Shorthand for debugging thread queue of a processor */
624 void 
625 GTQ(PEs p) { G_THREADQ(run_queue_hds[p],1); } 
626
627 /* Shorthand for debugging thread queue of current processor */
628 void 
629 GCTQ() { G_THREADQ(run_queue_hds[CurrentProc],1); } 
630
631 /* Shorthand for debugging spark queue of a processor */
632 void
633 GSQ(PEs p) { G_SPARKQ(pending_sparks_hds[p],1); }
634
635 /* Shorthand for debugging spark queue of current processor */
636 void
637 GCSQ() { G_CURR_SPARKQ(1); }
638
639 /* Shorthand for printing a node */
640 void
641 GN(StgPtr node) { G_PRINT_NODE(node); }
642
643 /* Shorthand for printing info table */
644 #if 0
645 // ToDo: fix -- HWL
646 void
647 GIT(StgPtr node) { G_INFO_TABLE(node); }
648 #endif
649
650 void 
651 printThreadQPtrs(void)
652 {
653   PEs p;
654   for (p=0; p<RtsFlags.GranFlags.proc; p++) {
655     fprintf(stderr,", PE %d: (hd=%p,tl=%p)", 
656             run_queue_hds[p], run_queue_tls[p]);
657   }
658 }
659
660 void
661 printThreadQ(StgTSO *tso) { G_THREADQ(tso, 0); };
662
663 void
664 printSparkQ(rtsSpark *spark) { G_SPARKQ(spark, 0); };
665
666 void
667 printThreadQ_verbose(StgTSO *tso) { G_THREADQ(tso, 1); };
668
669 void
670 printSparkQ_verbose(rtsSpark *spark) { G_SPARKQ(spark, 1); };
671
672 /* Shorthand for some of ADRs debugging functions */
673
674 #endif /* GRAN && GRAN_CHECK*/
675
676 #if 0
677 void
678 DEBUG_PRINT_NODE(node)
679 StgPtr node;
680 {
681    W_ info_ptr = INFO_PTR(node);
682    StgInt size = 0, ptrs = 0, i, vhs = 0;
683    char info_type[80];
684
685    info_hdr_type(info_ptr, info_type);
686
687    size_and_ptrs(node,&size,&ptrs);
688    vhs = var_hdr_size(node);
689
690    fprintf(stderr,"Node: 0x%lx", (W_) node);
691
692 #if defined(PAR)
693    fprintf(stderr," [GA: 0x%lx]",GA(node));
694 #endif
695
696 #if defined(PROFILING)
697    fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
698 #endif
699
700 #if defined(GRAN)
701    fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
702 #endif
703
704    fprintf(stderr," IP: 0x%lx (%s), size %ld, %ld ptrs\n",
705                   info_ptr,info_type,size,ptrs);
706
707    /* For now, we ignore the variable header */
708
709    for(i=0; i < size; ++i)
710      {
711        if(i == 0)
712          fprintf(stderr,"Data: ");
713
714        else if(i % 6 == 0)
715          fprintf(stderr,"\n      ");
716
717        if(i < ptrs)
718          fprintf(stderr," 0x%lx[P]",*(node+_HS+vhs+i));
719        else
720          fprintf(stderr," %lu[D]",*(node+_HS+vhs+i));
721      }
722    fprintf(stderr, "\n");
723 }
724
725
726 #define INFO_MASK       0x80000000
727
728 void
729 DEBUG_TREE(node)
730 StgPtr node;
731 {
732   W_ size = 0, ptrs = 0, i, vhs = 0;
733
734   /* Don't print cycles */
735   if((INFO_PTR(node) & INFO_MASK) != 0)
736     return;
737
738   size_and_ptrs(node,&size,&ptrs);
739   vhs = var_hdr_size(node);
740
741   DEBUG_PRINT_NODE(node);
742   fprintf(stderr, "\n");
743
744   /* Mark the node -- may be dangerous */
745   INFO_PTR(node) |= INFO_MASK;
746
747   for(i = 0; i < ptrs; ++i)
748     DEBUG_TREE((StgPtr)node[i+vhs+_HS]);
749
750   /* Unmark the node */
751   INFO_PTR(node) &= ~INFO_MASK;
752 }
753
754
755 void
756 DEBUG_INFO_TABLE(node)
757 StgPtr node;
758 {
759   W_ info_ptr = INFO_PTR(node);
760   char *iStgPtrtype = info_hdr_type(info_ptr);
761
762   fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
763                  iStgPtrtype,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
764 #if defined(PAR)
765   fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
766 #endif
767
768 #if defined(PROFILING)
769   fprintf(stderr,"Cost Centre (?):       0x%lx\n",INFO_CAT(info_ptr));
770 #endif
771
772 #if defined(_INFO_COPYING)
773   fprintf(stderr,"Evacuate Entry:    0x%lx;\tScavenge Entry: 0x%lx\n",
774           INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
775 #endif
776
777 #if defined(_INFO_COMPACTING)
778   fprintf(stderr,"Scan Link:         0x%lx;\tScan Move:      0x%lx\n",
779           (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
780   fprintf(stderr,"Mark:              0x%lx;\tMarked:         0x%lx;\t",
781           (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
782 #if 0 /* avoid INFO_TYPE */
783   if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
784     fprintf(stderr,"plus specialised code\n");
785   else
786     fprintf(stderr,"Marking:           0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
787 #endif /* 0 */
788 #endif /* _INFO_COMPACTING */
789 }
790 #endif /* 0 */
791
792 //@node Printing info type, Printing Packet Contents, Shortcuts, Debugging routines for GranSim and GUM
793 //@subsection Printing info type
794
795 char *
796 display_info_type(closure, str)
797 StgClosure *closure;
798 char *str;
799
800   strcpy(str,"");
801   if ( closure_HNF(closure) )
802     strcat(str,"|_HNF ");
803   else if ( closure_BITMAP(closure) )
804     strcat(str,"|_BTM");
805   else if ( !closure_SHOULD_SPARK(closure) )
806     strcat(str,"|_NS");
807   else if ( closure_STATIC(closure) )
808     strcat(str,"|_STA");
809   else if ( closure_THUNK(closure) )
810     strcat(str,"|_THU");
811   else if ( closure_MUTABLE(closure) )
812     strcat(str,"|_MUT");
813   else if ( closure_UNPOINTED(closure) )
814     strcat(str,"|_UPT");
815   else if ( closure_SRT(closure) )
816     strcat(str,"|_SRT");
817
818   return(str);
819 }
820
821 /*
822   PrintPacket is in Pack.c because it makes use of closure queues
823 */
824
825 #if defined(GRAN) || defined(PAR)
826
827 /*
828   Print graph rooted at q. The structure of this recursive printing routine
829   should be the same as in the graph traversals when packing a graph in
830   GUM. Thus, it demonstrates the structure of such a generic graph
831   traversal, and in particular, how to extract pointer and non-pointer info
832   from the multitude of different heap objects available. 
833
834   {evacuate}Daq ngoqvam nIHlu'pu'!!
835 */
836
837 void
838 PrintGraph(StgClosure *p, int indent_level)
839 {
840   void PrintGraph_(StgClosure *p, int indent_level);
841
842   ASSERT(tmpClosureTable==NULL);
843
844   /* init hash table */
845   tmpClosureTable = allocHashTable();
846
847   /* now do the real work */
848   PrintGraph_(p, indent_level);
849
850   /* nuke hash table */
851   freeHashTable(tmpClosureTable, NULL);
852   tmpClosureTable = NULL;
853 }
854
855 /*
856   This is the actual worker functions. 
857   All recursive calls should be made to this function.
858 */
859 void
860 PrintGraph_(StgClosure *p, int indent_level)
861 {
862   StgPtr x, q;
863   rtsBool printed = rtsFalse;
864   nat i, j;
865   const StgInfoTable *info;
866   
867   /* check whether we have met this node already to break cycles */
868   if (lookupHashTable(tmpClosureTable, (StgWord)p)) { // ie. already touched
869     /* indentation */
870     for (j=0; j<indent_level; j++)
871       fputs(" ", stderr);
872
873     fprintf(stderr, "#### cylce to %p", p);
874     return; 
875   }
876
877   /* record that we are processing this closure */
878   insertHashTable(tmpClosureTable, (StgWord) p, (void *)rtsTrue/*non-NULL*/);
879
880   q = p;                        /* save ptr to object */
881   
882   /* indentation */
883   for (j=0; j<indent_level; j++)
884     fputs(" ", stderr);
885
886   ASSERT(p!=(StgClosure*)NULL);
887   ASSERT(LOOKS_LIKE_STATIC(p) ||
888          LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p)) ||
889          IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p)));
890
891   printClosure(p); // prints contents of this one closure
892
893   /* indentation */
894   for (j=0; j<indent_level; j++)
895     fputs(" ", stderr);
896
897   info = get_itbl((StgClosure *)p);
898   /* the rest of this fct recursively traverses the graph */
899   switch (info -> type) {
900   
901   case BCO:
902     {
903         StgBCO* bco = stgCast(StgBCO*,p);
904         nat i;
905         fprintf(stderr, "BCO (%p)\n", p);
906         /*
907         for (i = 0; i < bco->n_ptrs; i++) {
908           // bcoConstCPtr(bco,i) = 
909           PrintGraph_(bcoConstCPtr(bco,i), indent_level+1);
910         }
911         */
912         // p += bco_sizeW(bco);
913         break;
914     }
915   
916   case MVAR:
917     /* treat MVars specially, because we don't want to PrintGraph the
918      * mut_link field in the middle of the closure.
919      */
920     { 
921         StgMVar *mvar = ((StgMVar *)p);
922         // evac_gen = 0;
923         fprintf(stderr, "MVAR (%p) with 3 pointers (head, tail, value)\n", p);
924         // (StgClosure *)mvar->head = 
925         PrintGraph_((StgClosure *)mvar->head, indent_level+1);
926         // (StgClosure *)mvar->tail = 
927         PrintGraph_((StgClosure *)mvar->tail, indent_level+1);
928         //(StgClosure *)mvar->value = 
929         PrintGraph_((StgClosure *)mvar->value, indent_level+1);
930         // p += sizeofW(StgMVar);
931         // evac_gen = saved_evac_gen;
932         break;
933     }
934   
935   case THUNK_2_0:
936     if (!printed) {
937       fprintf(stderr, "THUNK_2_0 (%p) with 2 pointers\n", p);
938       printed = rtsTrue;
939     }
940   case FUN_2_0:
941     if (!printed) {
942       fprintf(stderr, "FUN_2_0 (%p) with 2 pointers\n", p);
943       printed = rtsTrue;
944     }
945     // scavenge_srt(info);
946   case CONSTR_2_0:
947     if (!printed) {
948       fprintf(stderr, "CONSTR_2_0 (%p) with 2 pointers\n", p);
949       printed = rtsTrue;
950     }
951     // ((StgClosure *)p)->payload[0] = 
952     PrintGraph_(((StgClosure *)p)->payload[0],
953                indent_level+1);
954     // ((StgClosure *)p)->payload[1] = 
955     PrintGraph_(((StgClosure *)p)->payload[1],
956                indent_level+1);
957     // p += sizeofW(StgHeader) + 2;
958     break;
959   
960   case THUNK_1_0:
961     // scavenge_srt(info);
962     fprintf(stderr, "THUNK_1_0 (%p) with 1 pointer\n", p);
963     // ((StgClosure *)p)->payload[0] = 
964     PrintGraph_(((StgClosure *)p)->payload[0],
965                indent_level+1);
966     // p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
967     break;
968   
969   case FUN_1_0:
970     if (!printed) {
971       fprintf(stderr, "FUN_1_0 (%p) with 1 pointer\n", p);
972       printed = rtsTrue;
973     }
974     // scavenge_srt(info);
975   case CONSTR_1_0:
976     if (!printed) {
977       fprintf(stderr, "CONSTR_2_0 (%p) with 2 pointers\n", p);
978       printed = rtsTrue;
979     }
980     // ((StgClosure *)p)->payload[0] = 
981     PrintGraph_(((StgClosure *)p)->payload[0],
982                indent_level+1);
983     // p += sizeofW(StgHeader) + 1;
984     break;
985   
986   case THUNK_0_1:
987     fprintf(stderr, "THUNK_0_1 (%p) with 0 pointers\n", p);
988     // scavenge_srt(info);
989     // p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
990     break;
991   
992   case FUN_0_1:
993     fprintf(stderr, "FUN_0_1 (%p) with 0 pointers\n", p);
994     //scavenge_srt(info);
995   case CONSTR_0_1:
996     fprintf(stderr, "CONSTR_0_1 (%p) with 0 pointers\n", p);
997     //p += sizeofW(StgHeader) + 1;
998     break;
999   
1000   case THUNK_0_2:
1001     if (!printed) {
1002       fprintf(stderr, "THUNK_0_2 (%p) with 0 pointers\n", p);
1003       printed = rtsTrue;
1004     }
1005   case FUN_0_2:
1006     if (!printed) {
1007       fprintf(stderr, "FUN_0_2 (%p) with 0 pointers\n", p);
1008       printed = rtsTrue;
1009     }
1010     // scavenge_srt(info);
1011   case CONSTR_0_2:
1012     if (!printed) {
1013       fprintf(stderr, "CONSTR_0_2 (%p) with 0 pointers\n", p);
1014       printed = rtsTrue;
1015     }
1016     // p += sizeofW(StgHeader) + 2;
1017     break;
1018   
1019   case THUNK_1_1:
1020     if (!printed) {
1021       fprintf(stderr, "THUNK_1_1 (%p) with 1 pointer\n", p);
1022       printed = rtsTrue;
1023     }
1024   case FUN_1_1:
1025     if (!printed) {
1026       fprintf(stderr, "FUN_1_1 (%p) with 1 pointer\n", p);
1027       printed = rtsTrue;
1028     }
1029     // scavenge_srt(info);
1030   case CONSTR_1_1:
1031     if (!printed) {
1032       fprintf(stderr, "CONSTR_1_1 (%p) with 1 pointer\n", p);
1033       printed = rtsTrue;
1034     }
1035     // ((StgClosure *)p)->payload[0] = 
1036     PrintGraph_(((StgClosure *)p)->payload[0],
1037                indent_level+1);
1038     // p += sizeofW(StgHeader) + 2;
1039     break;
1040   
1041   case FUN:
1042     if (!printed) {
1043       fprintf(stderr, "FUN (%p) with %d pointers\n", p, info->layout.payload.ptrs);
1044       printed = rtsTrue;
1045     }
1046     /* fall through */
1047   
1048   case THUNK:
1049     if (!printed) {
1050       fprintf(stderr, "THUNK (%p) with %d pointers\n", p, info->layout.payload.ptrs);
1051       printed = rtsTrue;
1052     }
1053     // scavenge_srt(info);
1054     /* fall through */
1055   
1056   case CONSTR:
1057     if (!printed) {
1058       fprintf(stderr, "CONSTR (%p) with %d pointers\n", p, info->layout.payload.ptrs);
1059       printed = rtsTrue;
1060     }
1061     /* basically same as loop in STABLE_NAME case  */
1062     for (i=0; i<info->layout.payload.ptrs; i++)
1063       PrintGraph_(((StgClosure *)p)->payload[i],
1064                  indent_level+1);
1065     break;
1066     /* NOT fall through */
1067   
1068   case WEAK:
1069     if (!printed) {
1070       fprintf(stderr, "WEAK (%p) with %d pointers\n", p, info->layout.payload.ptrs);
1071       printed = rtsTrue;
1072     }
1073     /* fall through */
1074   
1075   case FOREIGN:
1076     if (!printed) {
1077       fprintf(stderr, "FOREIGN (%p) with %d pointers\n", p, info->layout.payload.ptrs);
1078       printed = rtsTrue;
1079     }
1080     /* fall through */
1081   
1082   case STABLE_NAME:
1083     {
1084       StgPtr end;
1085       
1086       if (!printed) {
1087         fprintf(stderr, "STABLE_NAME (%p) with %d pointers (not followed!)\n", 
1088                 p, info->layout.payload.ptrs);
1089         printed = rtsTrue;
1090       }
1091       end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1092       for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
1093         // (StgClosure *)*p = 
1094         //PrintGraph_((StgClosure *)*p, indent_level+1);
1095         fprintf(stderr, ", %p", *p); 
1096       }
1097       //fputs("\n", stderr);
1098       // p += info->layout.payload.nptrs;
1099       break;
1100     }
1101   
1102   case IND_PERM:
1103     //if (step->gen->no != 0) {
1104     //  SET_INFO(((StgClosure *)p), &IND_OLDGEN_PERM_info);
1105     //}
1106     if (!printed) {
1107       fprintf(stderr, "IND_PERM (%p) with indirection to\n", 
1108               p, ((StgIndOldGen *)p)->indirectee);
1109       printed = rtsTrue;
1110     }
1111     /* fall through */
1112
1113   case IND_OLDGEN_PERM:
1114     if (!printed) {
1115       fprintf(stderr, "IND_OLDGEN_PERM (%p) with indirection to %p\n", 
1116               p, ((StgIndOldGen *)p)->indirectee);
1117       printed = rtsTrue;
1118     }
1119     // ((StgIndOldGen *)p)->indirectee = 
1120     PrintGraph_(((StgIndOldGen *)p)->indirectee,
1121                indent_level+1);
1122     //if (failed_to_evac) {
1123     //  failed_to_evac = rtsFalse;
1124     //  recordOldToNewPtrs((StgMutClosure *)p);
1125     //}
1126     // p += sizeofW(StgIndOldGen);
1127     break;
1128   
1129   case MUT_VAR:
1130     /* ignore MUT_CONSs */
1131     fprintf(stderr, "MUT_VAR (%p) pointing to %p\n", p, ((StgMutVar *)p)->var);
1132     if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
1133       //evac_gen = 0;
1134       PrintGraph_(((StgMutVar *)p)->var, indent_level+1);
1135         //evac_gen = saved_evac_gen;
1136     }
1137     //p += sizeofW(StgMutVar);
1138     break;
1139   
1140   case CAF_BLACKHOLE:
1141     if (!printed) {
1142       fprintf(stderr, "CAF_BLACKHOLE (%p) with 0 pointers\n", p);
1143       printed = rtsTrue;
1144     }
1145   case SE_CAF_BLACKHOLE:
1146     if (!printed) {
1147       fprintf(stderr, "SE_CAF_BLACKHOLE (%p) with 0 pointers\n", p);
1148       printed = rtsTrue;
1149     }
1150   case SE_BLACKHOLE:
1151     if (!printed) {
1152       fprintf(stderr, "SE_BLACKHOLE (%p) with 0 pointers\n", p);
1153       printed = rtsTrue;
1154     }
1155   case BLACKHOLE:
1156     if (!printed) {
1157       fprintf(stderr, "BLACKHOLE (%p) with 0 pointers\n", p);
1158       printed = rtsTrue;
1159     }
1160     //p += BLACKHOLE_sizeW();
1161     break;
1162   
1163   case BLACKHOLE_BQ:
1164     { 
1165       StgBlockingQueue *bh = (StgBlockingQueue *)p;
1166       // (StgClosure *)bh->blocking_queue = 
1167       fprintf(stderr, "BLACKHOLE_BQ (%p) pointing to %p\n", 
1168               p, (StgClosure *)bh->blocking_queue);
1169       PrintGraph_((StgClosure *)bh->blocking_queue, indent_level+1);
1170       //if (failed_to_evac) {
1171       //  failed_to_evac = rtsFalse;
1172       //  recordMutable((StgMutClosure *)bh);
1173       //}
1174       // p += BLACKHOLE_sizeW();
1175       break;
1176     }
1177   
1178   case THUNK_SELECTOR:
1179     { 
1180       StgSelector *s = (StgSelector *)p;
1181       fprintf(stderr, "THUNK_SELECTOR (%p) pointing to %p\n", 
1182               p, s->selectee);
1183       PrintGraph_(s->selectee, indent_level+1);
1184       // p += THUNK_SELECTOR_sizeW();
1185       break;
1186     }
1187   
1188   case IND:
1189     fprintf(stderr, "IND (%p) pointing to %p\n", p, ((StgInd*)p)->indirectee);
1190     PrintGraph_(((StgInd*)p)->indirectee, indent_level+1);
1191     break;
1192
1193   case IND_OLDGEN:
1194     fprintf(stderr, "IND_OLDGEN (%p) pointing to %p\n", 
1195             p, ((StgIndOldGen*)p)->indirectee);
1196     PrintGraph_(((StgIndOldGen*)p)->indirectee, indent_level+1);
1197     break;
1198   
1199   case CONSTR_INTLIKE:
1200     fprintf(stderr, "CONSTR_INTLIKE (%p) with 0 pointers\n", p);
1201     break;
1202   case CONSTR_CHARLIKE:
1203     fprintf(stderr, "CONSTR_CHARLIKE (%p) with 0 pointers\n", p);
1204     break;
1205   case CONSTR_STATIC:
1206     fprintf(stderr, "CONSTR_STATIC (%p) with 0 pointers\n", p);
1207     break;
1208   case CONSTR_NOCAF_STATIC:
1209     fprintf(stderr, "CONSTR_NOCAF_STATIC (%p) with 0 pointers\n", p);
1210     break;
1211   case THUNK_STATIC:
1212     fprintf(stderr, "THUNK_STATIC (%p) with 0 pointers\n", p);
1213     break;
1214   case FUN_STATIC:
1215     fprintf(stderr, "FUN_STATIC (%p) with 0 pointers\n", p);
1216     break;
1217   case IND_STATIC:
1218     fprintf(stderr, "IND_STATIC (%p) with 0 pointers\n", p);
1219     break;
1220   
1221   case RET_BCO:
1222     fprintf(stderr, "RET_BCO (%p) with 0 pointers\n", p);
1223     break;
1224   case RET_SMALL:
1225     fprintf(stderr, "RET_SMALL (%p) with 0 pointers\n", p);
1226     break;
1227   case RET_VEC_SMALL:
1228     fprintf(stderr, "RET_VEC_SMALL (%p) with 0 pointers\n", p);
1229     break;
1230   case RET_BIG:
1231     fprintf(stderr, "RET_BIG (%p) with 0 pointers\n", p);
1232     break;
1233   case RET_VEC_BIG:
1234     fprintf(stderr, "RET_VEC_BIG (%p) with 0 pointers\n", p);
1235     break;
1236   case RET_DYN:
1237     fprintf(stderr, "RET_DYN (%p) with 0 pointers\n", p);
1238     break;
1239   case UPDATE_FRAME:
1240     fprintf(stderr, "UPDATE_FRAME (%p) with 0 pointers\n", p);
1241     break;
1242   case STOP_FRAME:
1243     fprintf(stderr, "STOP_FRAME (%p) with 0 pointers\n", p);
1244     break;
1245   case CATCH_FRAME:
1246     fprintf(stderr, "CATCH_FRAME (%p) with 0 pointers\n", p);
1247     break;
1248   case SEQ_FRAME:
1249     fprintf(stderr, "SEQ_FRAME (%p) with 0 pointers\n", p);
1250     break;
1251   
1252   case AP_UPD: /* same as PAPs */
1253     fprintf(stderr, "AP_UPD (%p) with 0 pointers\n", p);
1254   case PAP:
1255     /* Treat a PAP just like a section of stack, not forgetting to
1256      * PrintGraph_ the function pointer too...
1257      */
1258     { 
1259         StgPAP* pap = stgCast(StgPAP*,p);
1260   
1261         fprintf(stderr, "PAP (%p) pointing to %p\n", p, pap->fun);
1262         // pap->fun = 
1263         //PrintGraph_(pap->fun, indent_level+1);
1264         //scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
1265         //p += pap_sizeW(pap);
1266         break;
1267     }
1268     
1269   case ARR_WORDS:
1270     /* an array of (non-mutable) words */
1271     fprintf(stderr, "ARR_WORDS (%p) of %d non-ptrs (maybe a string?)\n", 
1272             p, ((StgArrWords *)q)->words);
1273     break;
1274
1275   case MUT_ARR_PTRS:
1276     /* follow everything */
1277     {
1278         StgPtr next;
1279   
1280         fprintf(stderr, "MUT_ARR_PTRS (%p) with %d pointers (not followed)\n", 
1281                 p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p));
1282         // evac_gen = 0;                /* repeatedly mutable */
1283         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1284         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1285           // (StgClosure *)*p = 
1286           // PrintGraph_((StgClosure *)*p, indent_level+1);
1287           fprintf(stderr, ", %p", *p); 
1288         }
1289         fputs("\n", stderr);
1290         //evac_gen = saved_evac_gen;
1291         break;
1292     }
1293   
1294   case MUT_ARR_PTRS_FROZEN:
1295     /* follow everything */
1296     {
1297         StgPtr start = p, next;
1298   
1299         fprintf(stderr, "MUT_ARR_PTRS (%p) with %d pointers (not followed)", 
1300                 p, mut_arr_ptrs_sizeW((StgMutArrPtrs*)p));
1301         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1302         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1303           // (StgClosure *)*p = 
1304           // PrintGraph_((StgClosure *)*p, indent_level+1);
1305           fprintf(stderr, ", %p", *p); 
1306         }
1307         fputs("\n", stderr);
1308         //if (failed_to_evac) {
1309           /* we can do this easier... */
1310         //  recordMutable((StgMutClosure *)start);
1311         //  failed_to_evac = rtsFalse;
1312         //}
1313         break;
1314     }
1315   
1316   case TSO:
1317     { 
1318         StgTSO *tso;
1319         
1320         tso = (StgTSO *)p;
1321         fprintf(stderr, "TSO (%p) with link field %p\n", p, (StgClosure *)tso->link);
1322         // evac_gen = 0;
1323         /* chase the link field for any TSOs on the same queue */
1324         // (StgClosure *)tso->link = 
1325         PrintGraph_((StgClosure *)tso->link, indent_level+1);
1326         //if (tso->blocked_on) {
1327         //  tso->blocked_on = PrintGraph_(tso->blocked_on);
1328         //}
1329         /* scavenge this thread's stack */
1330         //scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
1331         //evac_gen = saved_evac_gen;
1332         //p += tso_sizeW(tso);
1333         break;
1334     }
1335   
1336 #if defined(GRAN) || defined(PAR)
1337   case RBH:
1338     {
1339     StgInfoTable *rip = REVERT_INFOPTR(get_itbl(p));
1340     //if (LOOKS_LIKE_GHC_INFO(rip))
1341     //  fprintf(stderr, "RBH (%p) with 0 pointers (reverted type=%s)\n", 
1342         //      p, info_type_by_ip(rip)); 
1343     //else
1344     fprintf(stderr, "RBH (%p) with 0 pointers (reverted IP=%x)\n", 
1345             p, rip); 
1346     }
1347     break;
1348 #endif
1349 #if defined(PAR)
1350   case BLOCKED_FETCH:
1351     fprintf(stderr, "BLOCKED_FETCH (%p) with 0 pointers (link=%p)\n", 
1352             p, ((StgBlockedFetch *)p)->link);
1353     break;
1354   case FETCH_ME:
1355     fprintf(stderr, "FETCH_ME (%p) with 0 pointers\n", p);
1356     break;
1357   case FETCH_ME_BQ:
1358     fprintf(stderr, "FETCH_ME_BQ (%p) with 0 pointers (blocking_queue=%p)\n", 
1359             p, ((StgFetchMeBlockingQueue *)p)->blocking_queue);
1360     break;
1361 #endif
1362     
1363 #ifdef DIST    
1364   case REMOTE_REF:
1365     fprintf(stderr, "REMOTE_REF (%p) with 0 pointers\n", p);
1366     break;
1367 #endif
1368
1369   case EVACUATED:
1370     fprintf(stderr, "EVACUATED (%p) with 0 pointers (evacuee=%p)\n", 
1371             p, ((StgEvacuated *)p)->evacuee);
1372     break;
1373   
1374   default:
1375     barf("PrintGraph_: unknown closure %d (%s)",
1376          info -> type, info_type(info));
1377   }
1378   
1379   /* If we didn't manage to promote all the objects pointed to by
1380    * the current object, then we have to designate this object as
1381    * mutable (because it contains old-to-new generation pointers).
1382    */
1383   //if (failed_to_evac) {
1384   //  mkMutCons((StgClosure *)q, &generations[evac_gen]);
1385   //  failed_to_evac = rtsFalse;
1386   //}
1387 }    
1388
1389 # if defined(PAR)
1390 /*
1391   Generate a finger-print for a graph.
1392   A finger-print is a string, with each char representing one node; 
1393   depth-first traversal
1394 */
1395
1396 void
1397 GraphFingerPrint(StgClosure *p, char *finger_print)
1398 {
1399   void GraphFingerPrint_(StgClosure *p, char *finger_print);
1400
1401   ASSERT(tmpClosureTable==NULL);
1402   ASSERT(strlen(finger_print)==0);
1403
1404   /* init hash table */
1405   tmpClosureTable = allocHashTable();
1406
1407   /* now do the real work */
1408   GraphFingerPrint_(p, finger_print);
1409
1410   /* nuke hash table */
1411   freeHashTable(tmpClosureTable, NULL);
1412   tmpClosureTable = NULL;
1413 }
1414
1415 /*
1416   This is the actual worker functions. 
1417   All recursive calls should be made to this function.
1418 */
1419 void
1420 GraphFingerPrint_(StgClosure *p, char *finger_print)
1421 {
1422   StgPtr x, q;
1423   rtsBool printed = rtsFalse;
1424   nat i, j, len;
1425   const StgInfoTable *info;
1426
1427   q = p;                        /* save ptr to object */
1428   len = strlen(finger_print);
1429   ASSERT(len<=MAX_FINGER_PRINT_LEN);
1430   /* at most 7 chars for this node (I think) */
1431   if (len+7>=MAX_FINGER_PRINT_LEN)
1432     return;
1433
1434   /* check whether we have met this node already to break cycles */
1435   if (lookupHashTable(tmpClosureTable, (StgWord)p)) { // ie. already touched
1436     strcat(finger_print, "#");
1437     return; 
1438   }
1439
1440   /* record that we are processing this closure */
1441   insertHashTable(tmpClosureTable, (StgWord) p, (void *)rtsTrue/*non-NULL*/);
1442
1443   ASSERT(p!=(StgClosure*)NULL);
1444   ASSERT(LOOKS_LIKE_STATIC(p) ||
1445          LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p)) ||
1446          IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p)));
1447
1448   info = get_itbl((StgClosure *)p);
1449   // append char for this node
1450   finger_print[len] = finger_print_char[info->type]; finger_print[len+1] = '\0'; 
1451   /* the rest of this fct recursively traverses the graph */
1452   switch (info -> type) {
1453   
1454   case BCO:
1455     {
1456         StgBCO* bco = stgCast(StgBCO*,p);
1457         nat i;
1458         //%% fprintf(stderr, "BCO (%p) with %d pointers\n", p, bco->n_ptrs);
1459         /*
1460         for (i = 0; i < bco->n_ptrs; i++) {
1461           // bcoConstCPtr(bco,i) = 
1462           GraphFingerPrint_(bcoConstCPtr(bco,i), finger_print);
1463         }
1464         */
1465         // p += bco_sizeW(bco);
1466         break;
1467     }
1468   
1469   case MVAR:
1470     break;
1471   
1472   case THUNK_2_0:
1473   case FUN_2_0:
1474   case CONSTR_2_0:
1475     // append char for this node
1476     strcat(finger_print, "22(");
1477     GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
1478     GraphFingerPrint_(((StgClosure *)p)->payload[1], finger_print);
1479     if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
1480       strcat(finger_print, ")");
1481     break;
1482   
1483   case THUNK_1_0:
1484   case FUN_1_0:
1485   case CONSTR_1_0:
1486     // append char for this node
1487     strcat(finger_print, "12(");
1488     GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
1489     if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
1490       strcat(finger_print, ")");
1491     break;
1492   
1493   case THUNK_0_1:
1494   case FUN_0_1:
1495   case CONSTR_0_1:
1496     // append char for this node
1497     strcat(finger_print, "01");
1498     break;
1499   
1500   case THUNK_0_2:
1501   case FUN_0_2:
1502   case CONSTR_0_2:
1503     // append char for this node
1504     strcat(finger_print, "02");
1505     break;
1506   
1507   case THUNK_1_1:
1508   case FUN_1_1:
1509   case CONSTR_1_1:
1510     // append char for this node
1511     strcat(finger_print, "11(");
1512     GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
1513     if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
1514       strcat(finger_print, ")");
1515     break;
1516   
1517   case FUN:
1518   case THUNK:
1519   case CONSTR:
1520     /* basically same as loop in STABLE_NAME case  */
1521     {
1522         char str[6];
1523         sprintf(str,"%d?(",info->layout.payload.ptrs);
1524         strcat(finger_print,str); 
1525         for (i=0; i<info->layout.payload.ptrs; i++)
1526           GraphFingerPrint_(((StgClosure *)p)->payload[i], finger_print);
1527         if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
1528           strcat(finger_print, ")");
1529     }
1530     break;
1531   
1532   case WEAK:
1533   case FOREIGN:
1534   case STABLE_NAME:
1535     {
1536       StgPtr end;
1537       char str[6];
1538       sprintf(str,"%d?", info->layout.payload.ptrs);
1539       strcat(finger_print,str); 
1540
1541         //end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1542       //for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
1543       // GraphFingerPrint_((StgClosure *)*p, finger_print);
1544       //}
1545       break;
1546     }
1547   
1548   case IND_PERM:
1549   case IND_OLDGEN_PERM:
1550     GraphFingerPrint_(((StgIndOldGen *)p)->indirectee, finger_print);
1551     break;
1552   
1553   case MUT_VAR:
1554     /* ignore MUT_CONSs */
1555     if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
1556       GraphFingerPrint_(((StgMutVar *)p)->var, finger_print);
1557     }
1558     break;
1559   
1560   case CAF_BLACKHOLE:
1561   case SE_CAF_BLACKHOLE:
1562   case SE_BLACKHOLE:
1563   case BLACKHOLE:
1564     break;
1565   
1566   case BLACKHOLE_BQ:
1567     { 
1568       StgBlockingQueue *bh = (StgBlockingQueue *)p;
1569       // GraphFingerPrint_((StgClosure *)bh->blocking_queue, finger_print);
1570       break;
1571     }
1572   
1573   case THUNK_SELECTOR:
1574     { 
1575       StgSelector *s = (StgSelector *)p;
1576       GraphFingerPrint_(s->selectee, finger_print);
1577       break;
1578     }
1579   
1580   case IND:
1581     GraphFingerPrint_(((StgInd*)p)->indirectee, finger_print);
1582     break;
1583
1584   case IND_OLDGEN:
1585     GraphFingerPrint_(((StgIndOldGen*)p)->indirectee, finger_print);
1586     break;
1587
1588   case IND_STATIC:
1589     GraphFingerPrint_(((StgIndOldGen*)p)->indirectee, finger_print);
1590     break;
1591   
1592   case CONSTR_INTLIKE:
1593   case CONSTR_CHARLIKE:
1594   case CONSTR_STATIC:
1595   case CONSTR_NOCAF_STATIC:
1596   case THUNK_STATIC:
1597   case FUN_STATIC:
1598     break;
1599   
1600   case RET_BCO:
1601   case RET_SMALL:
1602   case RET_VEC_SMALL:
1603   case RET_BIG:
1604   case RET_VEC_BIG:
1605   case RET_DYN:
1606   case UPDATE_FRAME:
1607   case STOP_FRAME:
1608   case CATCH_FRAME:
1609   case SEQ_FRAME:
1610     break;
1611   
1612   case AP_UPD: /* same as PAPs */
1613   case PAP:
1614     /* Treat a PAP just like a section of stack, not forgetting to
1615      * GraphFingerPrint_ the function pointer too...
1616      */
1617     { 
1618         StgPAP* pap = stgCast(StgPAP*,p);
1619         char str[6];
1620         sprintf(str,"%d",pap->n_args);
1621         strcat(finger_print,str); 
1622         //GraphFingerPrint_(pap->fun, finger_print); // ??
1623         break;
1624     }
1625     
1626   case ARR_WORDS:
1627     {
1628         char str[6];
1629         sprintf(str,"%d",((StgArrWords*)p)->words);
1630         strcat(finger_print,str); 
1631     }
1632     break;
1633
1634   case MUT_ARR_PTRS:
1635     /* follow everything */
1636     {
1637         char str[6];
1638         sprintf(str,"%d",((StgMutArrPtrs*)p)->ptrs);
1639         strcat(finger_print,str); 
1640     }
1641     {
1642         StgPtr next;
1643         //next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1644         //for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1645         //  GraphFingerPrint_((StgClosure *)*p, finger_print);
1646         //}
1647         break;
1648     }
1649   
1650   case MUT_ARR_PTRS_FROZEN:
1651     /* follow everything */
1652     {
1653         char str[6];
1654         sprintf(str,"%d",((StgMutArrPtrs*)p)->ptrs);
1655         strcat(finger_print,str); 
1656     }
1657     {
1658         StgPtr start = p, next;
1659         //next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1660         //for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1661         //  GraphFingerPrint_((StgClosure *)*p, finger_print);
1662         //}
1663         break;
1664     }
1665   
1666   case TSO:
1667     { 
1668       StgTSO *tso = (StgTSO *)p;
1669       char str[6];
1670       sprintf(str,"%d",tso->id);
1671       strcat(finger_print,str); 
1672     }
1673     //GraphFingerPrint_((StgClosure *)tso->link, indent_level+1);
1674     break;
1675   
1676 #if defined(GRAN) || defined(PAR)
1677   case RBH:
1678     {
1679       // use this
1680       // StgInfoTable *rip = REVERT_INFOPTR(get_itbl(p));
1681     }
1682     break;
1683 #endif
1684 #if defined(PAR)
1685   case BLOCKED_FETCH:
1686     break;
1687   case FETCH_ME:
1688     break;
1689   case FETCH_ME_BQ:
1690     break;
1691 #endif
1692 #ifdef DIST    
1693   case REMOTE_REF:
1694     break;
1695 #endif
1696   case EVACUATED:
1697     break;
1698   
1699   default:
1700     barf("GraphFingerPrint_: unknown closure %d (%s)",
1701          info -> type, info_type(info));
1702   }
1703  
1704 }    
1705 # endif /* PAR */
1706
1707 /*
1708   Do a sanity check on the whole graph, down to a recursion level of level.
1709   Same structure as PrintGraph (nona).
1710 */
1711 void
1712 checkGraph(StgClosure *p, int rec_level)
1713 {
1714   StgPtr x, q;
1715   nat i, j;
1716   const StgInfoTable *info;
1717   
1718   if (rec_level==0)
1719     return;
1720
1721   q = p;                        /* save ptr to object */
1722
1723   /* First, the obvious generic checks */
1724   ASSERT(p!=(StgClosure*)NULL);
1725   checkClosure(p);              /* see Sanity.c for what's actually checked */
1726
1727   info = get_itbl((StgClosure *)p);
1728   /* the rest of this fct recursively traverses the graph */
1729   switch (info -> type) {
1730   
1731   case BCO:
1732     {
1733         StgBCO* bco = stgCast(StgBCO*,p);
1734         nat i;
1735         /*
1736         for (i = 0; i < bco->n_ptrs; i++) {
1737           checkGraph(bcoConstCPtr(bco,i), rec_level-1);
1738         }
1739         */
1740         break;
1741     }
1742   
1743   case MVAR:
1744     /* treat MVars specially, because we don't want to PrintGraph the
1745      * mut_link field in the middle of the closure.
1746      */
1747     { 
1748         StgMVar *mvar = ((StgMVar *)p);
1749         checkGraph((StgClosure *)mvar->head, rec_level-1);
1750         checkGraph((StgClosure *)mvar->tail, rec_level-1);
1751         checkGraph((StgClosure *)mvar->value, rec_level-1);
1752         break;
1753     }
1754   
1755   case THUNK_2_0:
1756   case FUN_2_0:
1757   case CONSTR_2_0:
1758     checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
1759     checkGraph(((StgClosure *)p)->payload[1], rec_level-1);
1760     break;
1761   
1762   case THUNK_1_0:
1763     checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
1764     break;
1765   
1766   case FUN_1_0:
1767   case CONSTR_1_0:
1768     checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
1769     break;
1770   
1771   case THUNK_0_1:
1772     break;
1773   
1774   case FUN_0_1:
1775   case CONSTR_0_1:
1776     break;
1777   
1778   case THUNK_0_2:
1779   case FUN_0_2:
1780   case CONSTR_0_2:
1781     break;
1782   
1783   case THUNK_1_1:
1784   case FUN_1_1:
1785   case CONSTR_1_1:
1786     checkGraph(((StgClosure *)p)->payload[0], rec_level-1);
1787     break;
1788   
1789   case FUN:
1790   case THUNK:
1791   case CONSTR:
1792     for (i=0; i<info->layout.payload.ptrs; i++)
1793       checkGraph(((StgClosure *)p)->payload[i], rec_level-1);
1794     break;
1795   
1796   case WEAK:
1797   case FOREIGN:
1798   case STABLE_NAME:
1799     {
1800       StgPtr end;
1801       
1802       end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
1803       for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
1804         checkGraph(*(StgClosure **)p, rec_level-1);
1805       }
1806       break;
1807     }
1808   
1809   case IND_PERM:
1810   case IND_OLDGEN_PERM:
1811     checkGraph(((StgIndOldGen *)p)->indirectee, rec_level-1);
1812     break;
1813   
1814   case MUT_VAR:
1815     /* ignore MUT_CONSs */
1816     if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
1817       checkGraph(((StgMutVar *)p)->var, rec_level-1);
1818     }
1819     break;
1820   
1821   case CAF_BLACKHOLE:
1822   case SE_CAF_BLACKHOLE:
1823   case SE_BLACKHOLE:
1824   case BLACKHOLE:
1825     break;
1826   
1827   case BLACKHOLE_BQ:
1828     break;
1829   
1830   case THUNK_SELECTOR:
1831     { 
1832       StgSelector *s = (StgSelector *)p;
1833       checkGraph(s->selectee, rec_level-1);
1834       break;
1835     }
1836   
1837   case IND:
1838     checkGraph(((StgInd*)p)->indirectee, rec_level-1);
1839     break;
1840
1841   case IND_OLDGEN:
1842     checkGraph(((StgIndOldGen*)p)->indirectee, rec_level-1);
1843     break;
1844   
1845   case CONSTR_INTLIKE:
1846     break;
1847   case CONSTR_CHARLIKE:
1848     break;
1849   case CONSTR_STATIC:
1850     break;
1851   case CONSTR_NOCAF_STATIC:
1852     break;
1853   case THUNK_STATIC:
1854     break;
1855   case FUN_STATIC:
1856     break;
1857   case IND_STATIC:
1858     break;
1859   
1860   case RET_BCO:
1861     break;
1862   case RET_SMALL:
1863     break;
1864   case RET_VEC_SMALL:
1865     break;
1866   case RET_BIG:
1867     break;
1868   case RET_VEC_BIG:
1869     break;
1870   case RET_DYN:
1871     break;
1872   case UPDATE_FRAME:
1873     break;
1874   case STOP_FRAME:
1875     break;
1876   case CATCH_FRAME:
1877     break;
1878   case SEQ_FRAME:
1879     break;
1880   
1881   case AP_UPD: /* same as PAPs */
1882   case PAP:
1883     /* Treat a PAP just like a section of stack, not forgetting to
1884      * checkGraph the function pointer too...
1885      */
1886     { 
1887         StgPAP* pap = stgCast(StgPAP*,p);
1888   
1889         checkGraph(pap->fun, rec_level-1);
1890         break;
1891     }
1892     
1893   case ARR_WORDS:
1894     break;
1895
1896   case MUT_ARR_PTRS:
1897     /* follow everything */
1898     {
1899         StgPtr next;
1900   
1901         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1902         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1903           checkGraph(*(StgClosure **)p, rec_level-1);
1904         }
1905         break;
1906     }
1907   
1908   case MUT_ARR_PTRS_FROZEN:
1909     /* follow everything */
1910     {
1911         StgPtr start = p, next;
1912   
1913         next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
1914         for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
1915           checkGraph(*(StgClosure **)p, rec_level-1);
1916         }
1917         break;
1918     }
1919   
1920   case TSO:
1921     { 
1922         StgTSO *tso;
1923         
1924         tso = (StgTSO *)p;
1925         checkGraph((StgClosure *)tso->link, rec_level-1);
1926         break;
1927     }
1928   
1929 #if defined(GRAN) || defined(PAR)
1930   case RBH:
1931     break;
1932 #endif
1933 #if defined(PAR)
1934   case BLOCKED_FETCH:
1935     break;
1936   case FETCH_ME:
1937     break;
1938   case FETCH_ME_BQ:
1939     break;
1940 #endif
1941   case EVACUATED:
1942     barf("checkGraph: found EVACUATED closure %p (%s)",
1943          p, info_type(p));
1944     break;
1945   
1946   default:
1947   }
1948 }    
1949
1950 #endif /* GRAN */
1951
1952 #endif /* GRAN || PAR */
1953
1954 //@node End of File,  , Printing Packet Contents, Debugging routines for GranSim and GUM
1955 //@subsection End of File