+Now the main stg-called routines:
+
+\begin{code}
+/* ------------------------------------------------------------------------ */
+/* The following GranSim... fcts are stg-called from the threaded world. */
+/* ------------------------------------------------------------------------ */
+
+/* Called from HEAP_CHK -- NB: node and liveness are junk here now.
+ They are left temporarily to avoid complete recompilation.
+ KH
+*/
+void
+GranSimAllocate(n,node,liveness)
+I_ n;
+P_ node;
+W_ liveness;
+{
+ TSO_ALLOCS(CurrentTSO) += n;
+ ++TSO_BASICBLOCKS(CurrentTSO);
+
+ if (RTSflags.GranFlags.granSimStats_Heap) {
+ DumpRawGranEvent(CurrentProc,0,GR_ALLOC,CurrentTSO,
+ PrelBase_Z91Z93_closure,n);
+ }
+
+ TSO_EXECTIME(CurrentTSO) += RTSflags.GranFlags.gran_heapalloc_cost;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_heapalloc_cost;
+}
+
+/*
+ Subtract the values added above, if a heap check fails and
+ so has to be redone.
+*/
+void
+GranSimUnallocate(n,node,liveness)
+W_ n;
+P_ node;
+W_ liveness;
+{
+ TSO_ALLOCS(CurrentTSO) -= n;
+ --TSO_BASICBLOCKS(CurrentTSO);
+
+ TSO_EXECTIME(CurrentTSO) -= RTSflags.GranFlags.gran_heapalloc_cost;
+ CurrentTime[CurrentProc] -= RTSflags.GranFlags.gran_heapalloc_cost;
+}
+
+/* NB: We now inline this code via GRAN_EXEC rather than calling this fct */
+void
+GranSimExec(ariths,branches,loads,stores,floats)
+W_ ariths,branches,loads,stores,floats;
+{
+ W_ cost = RTSflags.GranFlags.gran_arith_cost*ariths +
+ RTSflags.GranFlags.gran_branch_cost*branches +
+ RTSflags.GranFlags.gran_load_cost * loads +
+ RTSflags.GranFlags.gran_store_cost*stores +
+ RTSflags.GranFlags.gran_float_cost*floats;
+
+ TSO_EXECTIME(CurrentTSO) += cost;
+ CurrentTime[CurrentProc] += cost;
+}
+
+
+/*
+ Fetch the node if it isn't local
+ -- result indicates whether fetch has been done.
+
+ This is GRIP-style single item fetching.
+*/
+
+/* This function in Threads.lc is only needed for SimplifiedFetch */
+FetchNode PROTO((P_ node,PROC CurrentProc));
+
+I_
+GranSimFetch(node /* , liveness_mask */ )
+P_ node;
+/* I_ liveness_mask; */
+{
+ if (RTSflags.GranFlags.Light) {
+ /* Always reschedule in GrAnSim-Light to prevent one TSO from
+ running off too far
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ CONTINUETHREAD,CurrentTSO,node,NULL);
+ */
+ NeedToReSchedule = rtsFalse;
+ return(0);
+ }
+
+ /* Note: once a node has been fetched, this test will be passed */
+ if(!IS_LOCAL_TO(PROCS(node),CurrentProc))
+ {
+ /* Add mpacktime to the remote PE for the reply */
+ {
+ PROC p = where_is(node);
+ TIME fetchtime;
+
+# ifdef GRAN_CHECK
+ if ( ( RTSflags.GranFlags.debug & 0x40 ) &&
+ p == CurrentProc )
+ fprintf(stderr,"GranSimFetch: Trying to fetch from own processor%u\n", p);
+# endif /* GRAN_CHECK */
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
+ /* NB: Fetch is counted on arrival (FETCHREPLY) */
+
+ if (RTSflags.GranFlags.SimplifiedFetch)
+ {
+ FetchNode(node,CurrentProc);
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime+
+ RTSflags.GranFlags.gran_fetchtime+
+ RTSflags.GranFlags.gran_munpacktime;
+ return(1);
+ }
+
+ fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p]) +
+ RTSflags.GranFlags.gran_latency;
+
+ new_event(p,CurrentProc,fetchtime,FETCHNODE,CurrentTSO,node,NULL);
+ if (!RTSflags.GranFlags.DoReScheduleOnFetch)
+ MAKE_FETCHING(CurrentProc);
+ ++OutstandingFetches[CurrentProc];
+
+ if (fetchtime<TimeOfNextEvent)
+ TimeOfNextEvent = fetchtime;
+
+ /* About to block */
+ TSO_BLOCKEDAT(CurrentTSO) = CurrentTime[CurrentProc];
+
+ if (RTSflags.GranFlags.DoReScheduleOnFetch)
+ {
+ /* Remove CurrentTSO from the queue
+ -- assumes head of queue == CurrentTSO */
+ if(!RTSflags.GranFlags.DoFairSchedule)
+ {
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,
+ node,0);
+
+ ActivateNextThread(CurrentProc);
+
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x10) {
+ if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
+ fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
+ CurrentTSO,CurrentTime[CurrentProc]);
+ EXIT(EXIT_FAILURE);
+ } else {
+ TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
+ }
+ }
+# endif
+ TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;
+ /* CurrentTSO = PrelBase_Z91Z93_closure; */
+
+ /* ThreadQueueHd is now the next TSO to schedule or NULL */
+ /* CurrentTSO is pointed to by the FETCHNODE event */
+ }
+ else /* fair scheduling currently not supported -- HWL */
+ {
+ fprintf(stderr,"Reschedule-on-fetch is not yet compatible with fair scheduling\n");
+ EXIT(EXIT_FAILURE);
+ }
+ }
+ else /* !RTSflags.GranFlags.DoReScheduleOnFetch */
+ {
+ /* Note: CurrentProc is still busy as it's blocked on fetch */
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,node,0);
+
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x04)
+ BlockedOnFetch[CurrentProc] = CurrentTSO; /*- rtsTrue; -*/
+ if (RTSflags.GranFlags.debug & 0x10) {
+ if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
+ fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
+ CurrentTSO,CurrentTime[CurrentProc]);
+ EXIT(EXIT_FAILURE);
+ } else {
+ TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
+ }
+ CurrentTSO = PrelBase_Z91Z93_closure;
+ }
+# endif
+ }
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+
+ /* Rescheduling is necessary */
+ NeedToReSchedule = rtsTrue;
+
+ return(1);
+ }
+ }
+ return(0);
+}
+
+void
+GranSimSpark(local,node)
+W_ local;
+P_ node;
+{
+ /* ++SparksAvail; Nope; do that in add_to_spark_queue */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,(PROC)0,SP_SPARK,PrelBase_Z91Z93_closure,node,
+ spark_queue_len(CurrentProc,ADVISORY_POOL)-1);
+
+ /* Force the PE to take notice of the spark */
+ if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
+ if (CurrentTime[CurrentProc]<TimeOfNextEvent)
+ TimeOfNextEvent = CurrentTime[CurrentProc];
+ }
+
+ if(local)
+ ++TSO_LOCALSPARKS(CurrentTSO);
+ else
+ ++TSO_GLOBALSPARKS(CurrentTSO);
+}
+
+void
+GranSimSparkAt(spark,where,identifier)
+sparkq spark;
+P_ where; /* This should be a node; alternatively could be a GA */
+I_ identifier;
+{
+ PROC p = where_is(where);
+ GranSimSparkAtAbs(spark,p,identifier);
+}
+
+void
+GranSimSparkAtAbs(spark,proc,identifier)
+sparkq spark;
+PROC proc;
+I_ identifier;
+{
+ TIME exporttime;
+
+ if ( spark == (sparkq)NULL) /* Note: Granularity control might have */
+ return; /* turned a spark into a NULL. */
+
+ /* ++SparksAvail; Nope; do that in add_to_spark_queue */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(proc,0,SP_SPARKAT,PrelBase_Z91Z93_closure,SPARK_NODE(spark),
+ spark_queue_len(proc,ADVISORY_POOL));
+
+ if (proc!=CurrentProc) {
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
+ exporttime = (CurrentTime[proc] > CurrentTime[CurrentProc]?
+ CurrentTime[proc]: CurrentTime[CurrentProc])
+ + RTSflags.GranFlags.gran_latency;
+ } else {
+ exporttime = CurrentTime[CurrentProc];
+ }
+
+ if ( RTSflags.GranFlags.Light )
+ /* Need CurrentTSO in event field to associate costs with creating
+ spark even in a GrAnSim Light setup */
+ new_event(proc,CurrentProc,exporttime,
+ MOVESPARK,CurrentTSO,PrelBase_Z91Z93_closure,spark);
+ else
+ new_event(proc,CurrentProc,exporttime,
+ MOVESPARK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,spark);
+ /* Bit of a hack to treat placed sparks the same as stolen sparks */
+ ++OutstandingFishes[proc];
+
+ /* Force the PE to take notice of the spark (FINDWORK is put after a
+ MOVESPARK into the sparkq!) */
+ if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
+ new_event(CurrentProc,CurrentProc,exporttime+1,
+ FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
+ }
+
+ if (exporttime<TimeOfNextEvent)
+ TimeOfNextEvent = exporttime;
+
+ if (proc!=CurrentProc) {
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+ ++TSO_GLOBALSPARKS(CurrentTSO);
+ } else {
+ ++TSO_LOCALSPARKS(CurrentTSO);
+ }
+}
+
+/* This function handles local and global blocking */
+/* It's called either from threaded code (RBH_entry, BH_entry etc) or */
+/* from blockFetch when trying to fetch an BH or RBH */
+
+void
+GranSimBlock(P_ tso, PROC proc, P_ node)
+{
+ PROC node_proc = where_is(node);
+
+ ASSERT(tso==RunnableThreadsHd[proc]);
+
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(proc,node_proc,GR_BLOCK,tso,node,0);
+
+ ++TSO_BLOCKCOUNT(tso);
+ /* Distinction between local and global block is made in blockFetch */
+ TSO_BLOCKEDAT(tso) = CurrentTime[proc];
+
+ CurrentTime[proc] += RTSflags.GranFlags.gran_threadqueuetime;
+ ActivateNextThread(proc);
+ TSO_LINK(tso) = PrelBase_Z91Z93_closure; /* not really necessary; only for testing */
+}
+
+#endif /* GRAN */
+
+\end{code}
+
+%****************************************************************************
+%
+\subsection[GrAnSim-profile]{Writing profiling info for GrAnSim}
+%
+%****************************************************************************
+
+Event dumping routines.
+
+\begin{code}