+static W_
+arr_max(W_ arr[], I_ max)
+{
+ I_ i;
+ W_ res;
+
+ /* Doesn't work with max==0; but then, many things don't work in this */
+ /* special case. */
+ for (i=1, res = arr[0]; i<max; i++)
+ res = (arr[i]>res) ? arr[i] : res;
+
+ return (res);
+}
+
+/* In case of an excessive number of sparks, depth first pruning is a Bad */
+/* Idea as we might end up with all remaining sparks on processor 0 and */
+/* none on the other processors. So, this version uses breadth first */
+/* pruning. -- HWL */
+
+void
+PruneSparks(STG_NO_ARGS)
+{
+ sparkq spark, prev,
+ prev_spark[MAX_PROC][SPARK_POOLS],
+ curr_spark[MAX_PROC][SPARK_POOLS];
+ PROC proc;
+ W_ allProcs = 0,
+ endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
+ I_ pool, total_sparks=0,
+ prunedSparks[MAX_PROC][SPARK_POOLS];
+ I_ tot_sparks[MAX_PROC], tot = 0;;
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x40 )
+ fprintf(stderr,"Pruning (breadth-first) sparks for GC ...\n");
+# endif
+
+ /* Init */
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ allProcs |= PE_NUMBER(proc);
+ tot_sparks[proc] = 0;
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ prev_spark[proc][pool] = NULL;
+ curr_spark[proc][pool] = PendingSparksHd[proc][pool];
+ prunedSparks[proc][pool] = 0;
+ endQueues[pool] = 0;
+ finishedQueues[pool] = 0;
+ }
+ }
+
+ /* Breadth first pruning */
+ do {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ spark = curr_spark[proc][pool];
+ prev = prev_spark[proc][pool];
+
+ if (spark == NULL) { /* at the end of the queue already? */
+ if (! (endQueues[pool] & PE_NUMBER(proc)) ) {
+ endQueues[pool] |= PE_NUMBER(proc);
+ if (prev==NULL)
+ PendingSparksHd[proc][pool] = NULL;
+ else
+ SPARK_NEXT(prev) = NULL;
+ PendingSparksTl[proc][pool] = prev;
+ }
+ continue;
+ }
+
+ /* HACK! This clause should actually never happen HWL */
+ if ( (SPARK_NODE(spark) == NULL) ||
+ (SPARK_NODE(spark) == Prelude_Z91Z93_closure) ) {
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GcFlags.giveStats &&
+ (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Prelude_Z91Z93_closure\n", spark);
+# endif
+ /* prune it below */
+ } else if (SHOULD_SPARK(SPARK_NODE(spark))) {
+ if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0) {
+ if ( RTSflags.GcFlags.giveStats )
+ if (pool==ADVISORY_POOL) {
+ tot_sparks[proc]++;
+ tot++;
+ }
+
+ /* Keep it */
+ if (prev_spark[proc][pool] == NULL)
+ PendingSparksHd[proc][pool] = spark;
+ else
+ SPARK_NEXT(prev_spark[proc][pool]) = spark;
+ SPARK_PREV(spark) = prev_spark[proc][pool];
+ prev_spark[proc][pool] = spark;
+ curr_spark[proc][pool] = SPARK_NEXT(spark);
+ continue;
+ } else { /* total_sparks > MAX_SPARKS */
+ /* Sparkq will end before the current spark */
+ if (prev == NULL)
+ PendingSparksHd[proc][pool] = NULL;
+ else
+ SPARK_NEXT(prev) = NULL;
+ PendingSparksTl[proc][pool] = prev;
+ endQueues[pool] |= PE_NUMBER(proc);
+ continue;
+ }
+ }
+
+ /* By now we know that the spark has to be pruned */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
+ Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
+
+ SPARK_NODE(spark) = Prelude_Z91Z93_closure;
+ curr_spark[proc][pool] = SPARK_NEXT(spark);
+ prunedSparks[proc][pool]++;
+ DisposeSpark(spark);
+ } /* forall pool ... */
+ } /* forall proc ... */
+ } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
+
+ /* Prune all sparks on all processor starting with */
+ /* curr_spark[proc][pool]. */
+
+ do {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ spark = curr_spark[proc][pool];
+
+ if ( spark != NULL ) {
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
+ Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
+
+ SPARK_NODE(spark) = Prelude_Z91Z93_closure;
+ curr_spark[proc][pool] = SPARK_NEXT(spark);
+
+ prunedSparks[proc][pool]++;
+ DisposeSpark(spark);
+ } else {
+ finishedQueues[pool] |= PE_NUMBER(proc);
+ }
+ } /* forall pool ... */
+ } /* forall proc ... */
+ } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
+
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x1000) {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][pool]>0)) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
+ prunedSparks[proc][pool],proc,pool);
+ }
+ }
+ }
+
+ if ( RTSflags.GcFlags.giveStats ) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Spark statistics (after discarding) (total sparks = %d):",tot);
+ for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
+ if (proc % 4 == 0)
+ fprintf(RTSflags.GcFlags.statsFile,"\n> ");
+ fprintf(RTSflags.GcFlags.statsFile,
+ "\tPE %d: %d ",proc,tot_sparks[proc]);
+ }
+ fprintf(RTSflags.GcFlags.statsFile,".\n");
+ }
+ }
+# endif
+}
+
+# endif /* !DEPTH_FIRST_PRUNING */
+