- if(sizeof(TIME)==4)
- {
- putc('\0',gr_file);
- putc('\0',gr_file);
- putc('\0',gr_file);
- putc('\0',gr_file);
- }
- else
- {
- putc(v >> 56l,gr_file);
- putc((v >> 48l)&0xffl,gr_file);
- putc((v >> 40l)&0xffl,gr_file);
- putc((v >> 32l)&0xffl,gr_file);
- }
- putc((v >> 24l)&0xffl,gr_file);
- putc((v >> 16l)&0xffl,gr_file);
- putc((v >> 8l)&0xffl,gr_file);
- putc(v&0xffl,gr_file);
-}
-
-/*
- Length-coded output: first 3 bits contain length coding
-
- 00x 1 byte
- 01x 2 bytes
- 10x 4 bytes
- 110 8 bytes
- 111 5 or 9 bytes
-*/
-
-grputw(v)
-TIME v;
-{
- if(v <= 0x3fl)
- {
- fputc(v & 0x3f,gr_file);
- }
-
- else if (v <= 0x3fffl)
- {
- fputc((v >> 8l)|0x40l,gr_file);
- fputc(v&0xffl,gr_file);
- }
-
- else if (v <= 0x3fffffffl)
- {
- fputc((v >> 24l)|0x80l,gr_file);
- fputc((v >> 16l)&0xffl,gr_file);
- fputc((v >> 8l)&0xffl,gr_file);
- fputc(v&0xffl,gr_file);
- }
-
- else if (sizeof(TIME) == 4)
- {
- fputc(0x70,gr_file);
- fputc((v >> 24l)&0xffl,gr_file);
- fputc((v >> 16l)&0xffl,gr_file);
- fputc((v >> 8l)&0xffl,gr_file);
- fputc(v&0xffl,gr_file);
- }
-
- else
- {
- if (v <= 0x3fffffffffffffl)
- putc((v >> 56l)|0x60l,gr_file);
- else
- {
- putc(0x70,gr_file);
- putc((v >> 56l)&0xffl,gr_file);
- }
-
- putc((v >> 48l)&0xffl,gr_file);
- putc((v >> 40l)&0xffl,gr_file);
- putc((v >> 32l)&0xffl,gr_file);
- putc((v >> 24l)&0xffl,gr_file);
- putc((v >> 16l)&0xffl,gr_file);
- putc((v >> 8l)&0xffl,gr_file);
- putc(v&0xffl,gr_file);
- }
-}
-#endif /* GRAN */
-
-\end{code}
-
-%****************************************************************************
-%
-\subsection[GrAnSim-debug]{Debugging routines for GrAnSim}
-%
-%****************************************************************************
-
-Debugging routines, mainly for GrAnSim. They should really be in a separate file.
-
-The first couple of routines are general ones (look also into
-c-as-asm/StgDebug.lc).
-
-\begin{code}
-
-#define NULL_REG_MAP /* Not threaded */
-#include "stgdefs.h"
-
-char *
-info_hdr_type(info_ptr)
-W_ info_ptr;
-{
-#if ! defined(PAR) && !defined(GRAN)
- switch (INFO_TAG(info_ptr))
- {
- case INFO_OTHER_TAG:
- return("OTHER_TAG");
-/* case INFO_IND_TAG:
- return("IND_TAG");
-*/ default:
- return("TAG<n>");
- }
-#else /* PAR */
- switch(INFO_TYPE(info_ptr))
- {
- case INFO_SPEC_U_TYPE:
- return("SPECU");
-
- case INFO_SPEC_N_TYPE:
- return("SPECN");
-
- case INFO_GEN_U_TYPE:
- return("GENU");
-
- case INFO_GEN_N_TYPE:
- return("GENN");
-
- case INFO_DYN_TYPE:
- return("DYN");
-
- /*
- case INFO_DYN_TYPE_N:
- return("DYNN");
-
- case INFO_DYN_TYPE_U:
- return("DYNU");
- */
-
- case INFO_TUPLE_TYPE:
- return("TUPLE");
-
- case INFO_DATA_TYPE:
- return("DATA");
-
- case INFO_MUTUPLE_TYPE:
- return("MUTUPLE");
-
- case INFO_IMMUTUPLE_TYPE:
- return("IMMUTUPLE");
-
- case INFO_STATIC_TYPE:
- return("STATIC");
-
- case INFO_CONST_TYPE:
- return("CONST");
-
- case INFO_CHARLIKE_TYPE:
- return("CHAR");
-
- case INFO_INTLIKE_TYPE:
- return("INT");
-
- case INFO_BH_TYPE:
- return("BHOLE");
-
- case INFO_IND_TYPE:
- return("IND");
-
- case INFO_CAF_TYPE:
- return("CAF");
-
- case INFO_FETCHME_TYPE:
- return("FETCHME");
-
- case INFO_BQ_TYPE:
- return("BQ");
-
- /*
- case INFO_BQENT_TYPE:
- return("BQENT");
- */
-
- case INFO_TSO_TYPE:
- return("TSO");
-
- case INFO_STKO_TYPE:
- return("STKO");
-
- default:
- fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
- return("??");
- }
-#endif /* PAR */
-}
-
-/*
-@var_hdr_size@ computes the size of the variable header for a closure.
-*/
-
-I_
-var_hdr_size(node)
-P_ node;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE: return(0); /* by decree */
- case INFO_SPEC_N_TYPE: return(0);
- case INFO_GEN_U_TYPE: return(GEN_VHS);
- case INFO_GEN_N_TYPE: return(GEN_VHS);
- case INFO_DYN_TYPE: return(DYN_VHS);
- /*
- case INFO_DYN_TYPE_N: return(DYN_VHS);
- case INFO_DYN_TYPE_U: return(DYN_VHS);
- */
- case INFO_TUPLE_TYPE: return(TUPLE_VHS);
- case INFO_DATA_TYPE: return(DATA_VHS);
- case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS);
- case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
- case INFO_STATIC_TYPE: return(STATIC_VHS);
- case INFO_CONST_TYPE: return(0);
- case INFO_CHARLIKE_TYPE: return(0);
- case INFO_INTLIKE_TYPE: return(0);
- case INFO_BH_TYPE: return(0);
- case INFO_IND_TYPE: return(0);
- case INFO_CAF_TYPE: return(0);
- case INFO_FETCHME_TYPE: return(0);
- case INFO_BQ_TYPE: return(0);
- /*
- case INFO_BQENT_TYPE: return(0);
- */
- case INFO_TSO_TYPE: return(TSO_VHS);
- case INFO_STKO_TYPE: return(STKO_VHS);
- default:
- fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
- INFO_TYPE(INFO_PTR(node)));
- return(0);
- }
-}
-
-
-/* Determine the size and number of pointers for this kind of closure */
-void
-size_and_ptrs(node,size,ptrs)
-P_ node;
-W_ *size, *ptrs;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE:
- case INFO_SPEC_N_TYPE:
- *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */
- *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */
- /*
- *size = SPEC_CLOSURE_SIZE(node);
- *ptrs = SPEC_CLOSURE_NoPTRS(node);
- */
- break;
-
- case INFO_GEN_U_TYPE:
- case INFO_GEN_N_TYPE:
- *size = GEN_CLOSURE_SIZE(node);
- *ptrs = GEN_CLOSURE_NoPTRS(node);
- break;
-
- /*
- case INFO_DYN_TYPE_U:
- case INFO_DYN_TYPE_N:
- */
- case INFO_DYN_TYPE:
- *size = DYN_CLOSURE_SIZE(node);
- *ptrs = DYN_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_TUPLE_TYPE:
- *size = TUPLE_CLOSURE_SIZE(node);
- *ptrs = TUPLE_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_DATA_TYPE:
- *size = DATA_CLOSURE_SIZE(node);
- *ptrs = DATA_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_IND_TYPE:
- *size = IND_CLOSURE_SIZE(node);
- *ptrs = IND_CLOSURE_NoPTRS(node);
- break;
-
-/* ToDo: more (WDP) */
-
- /* Don't know about the others */
- default:
- *size = *ptrs = 0;
- break;
- }
-}
-
-void
-DEBUG_PRINT_NODE(node)
-P_ node;
-{
- W_ info_ptr = INFO_PTR(node);
- I_ size = 0, ptrs = 0, i, vhs = 0;
- char *info_type = info_hdr_type(info_ptr);
-
- 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(USE_COST_CENTRES)
- 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+_FHS+vhs+i));
- else
- fprintf(stderr," %lu[D]",*(node+_FHS+vhs+i));
- }
- fprintf(stderr, "\n");
-}
-
-
-#define INFO_MASK 0x80000000
-
-void
-DEBUG_TREE(node)
-P_ 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((P_)node[i+vhs+_FHS]);
-
- /* Unmark the node */
- INFO_PTR(node) &= ~INFO_MASK;
-}
-
-
-void
-DEBUG_INFO_TABLE(node)
-P_ node;
-{
- W_ info_ptr = INFO_PTR(node);
- char *ip_type = info_hdr_type(info_ptr);
-
- fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
- ip_type,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(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
-}
-#endif /* GRAN */
-
-\end{code}
-
-The remaining debugging routines are more or less specific for GrAnSim.
-
-\begin{code}
-#if defined(GRAN) && defined(GRAN_CHECK)
-void
-DEBUG_CURR_THREADQ(verbose)
-I_ verbose;
-{
- fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
- DEBUG_THREADQ(ThreadQueueHd, verbose);
-}
-
-void
-DEBUG_THREADQ(closure, verbose)
-P_ closure;
-I_ verbose;
-{
- P_ x;
-
- fprintf(stderr,"Thread Queue: ");
- for (x=closure; x!=Nil_closure; x=TSO_LINK(x))
- if (verbose)
- DEBUG_TSO(x,0);
- else
- fprintf(stderr," 0x%x",x);
-
- if (closure==Nil_closure)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-/* Check with Threads.lh */
-static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
-
-void
-DEBUG_TSO(closure,verbose)
-P_ closure;
-I_ verbose;
-{
-
- if (closure==Nil_closure) {
- fprintf(stderr,"TSO at 0x%x is Nil_closure!\n");
- return;
- }
-
- fprintf(stderr,"TSO at 0x%x has the following contents:\n",closure);
-
- fprintf(stderr,"> Name: 0x%x",TSO_NAME(closure));
- fprintf(stderr,"\tLink: 0x%x\n",TSO_LINK(closure));
- fprintf(stderr,"> Id: 0x%x",TSO_ID(closure));
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (debug & 0x10)
- fprintf(stderr,"\tType: %s %s\n",
- type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
- (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
- else
- fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
-#else
- fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
-#endif
- fprintf(stderr,"> PC1: 0x%x",TSO_PC1(closure));
- fprintf(stderr,"\tPC2: 0x%x\n",TSO_PC2(closure));
- fprintf(stderr,"> ARG1: 0x%x",TSO_ARG1(closure));
- fprintf(stderr,"\tARG2: 0x%x\n",TSO_ARG2(closure));
- fprintf(stderr,"> SWITCH: 0x%x\n", TSO_SWITCH(closure));
-
- if (verbose) {
- fprintf(stderr,"} LOCKED: 0x%x",TSO_LOCKED(closure));
- fprintf(stderr,"\tSPARKNAME: 0x%x\n", TSO_SPARKNAME(closure));
- fprintf(stderr,"} STARTEDAT: 0x%x", TSO_STARTEDAT(closure));
- fprintf(stderr,"\tEXPORTED: 0x%x\n", TSO_EXPORTED(closure));
- fprintf(stderr,"} BASICBLOCKS: 0x%x", TSO_BASICBLOCKS(closure));
- fprintf(stderr,"\tALLOCS: 0x%x\n", TSO_ALLOCS(closure));
- fprintf(stderr,"} EXECTIME: 0x%x", TSO_EXECTIME(closure));
- fprintf(stderr,"\tFETCHTIME: 0x%x\n", TSO_FETCHTIME(closure));
- fprintf(stderr,"} FETCHCOUNT: 0x%x", TSO_FETCHCOUNT(closure));
- fprintf(stderr,"\tBLOCKTIME: 0x%x\n", TSO_BLOCKTIME(closure));
- fprintf(stderr,"} BLOCKCOUNT: 0x%x", TSO_BLOCKCOUNT(closure));
- fprintf(stderr,"\tBLOCKEDAT: 0x%x\n", TSO_BLOCKEDAT(closure));
- fprintf(stderr,"} GLOBALSPARKS: 0x%x", TSO_GLOBALSPARKS(closure));
- fprintf(stderr,"\tLOCALSPARKS: 0x%x\n", TSO_LOCALSPARKS(closure));
- }
-}
-
-void
-DEBUG_EVENT(event, verbose)
-eventq event;
-I_ verbose;
-{
- if (verbose) {
- print_event(event);
- }else{
- fprintf(stderr," 0x%x",event);
- }
-}
-
-void
-DEBUG_EVENTQ(verbose)
-I_ verbose;
-{
- eventq x;
-
- fprintf(stderr,"Eventq (hd @0x%x):\n",EventHd);
- for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
- DEBUG_EVENT(x,verbose);
- }
- if (EventHd==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-DEBUG_SPARK(spark, verbose)
-sparkq spark;
-I_ verbose;
-{
- if (verbose)
- print_spark(spark);
- else
- fprintf(stderr," 0x%x",spark);
-}
-
-void
-DEBUG_SPARKQ(spark,verbose)
-sparkq spark;
-I_ verbose;
-{
- sparkq x;
-
- fprintf(stderr,"Sparkq (hd @0x%x):\n",spark);
- for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
- DEBUG_SPARK(x,verbose);
- }
- if (spark==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-DEBUG_CURR_SPARKQ(verbose)
-I_ verbose;
-{
- DEBUG_SPARKQ(SparkQueueHd,verbose);
-}
-
-void
-DEBUG_PROC(proc,verbose)
-I_ proc;
-I_ verbose;
-{
- fprintf(stderr,"Status of proc %d at time %d (0x%x): %s\n",
- proc,CurrentTime[proc],CurrentTime[proc],
- (CurrentProc==proc)?"ACTIVE":"INACTIVE");
- DEBUG_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
- if ( (CurrentProc==proc) )
- DEBUG_TSO(CurrentTSO,1);
-
- if (EventHd!=NULL)
- fprintf(stderr,"Next event (%s) is on proc %d\n",
- event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
-
- if (verbose & 0x1) {
- fprintf(stderr,"\nREQUIRED sparks: ");
- DEBUG_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
- fprintf(stderr,"\nADVISORY_sparks: ");
- DEBUG_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
- }
-}
-
-/* Debug CurrentTSO */
-void
-DCT(){
- fprintf(stderr,"Current Proc: %d\n",CurrentProc);
- DEBUG_TSO(CurrentTSO,1);
-}
-
-/* Debug Current Processor */
-void
-DCP(){ DEBUG_PROC(CurrentProc,2); }
-
-/* Shorthand for debugging event queue */
-void
-DEQ() { DEBUG_EVENTQ(1); }
-
-/* Shorthand for debugging spark queue */
-void
-DSQ() { DEBUG_CURR_SPARKQ(1); }
-
-/* Shorthand for printing a node */
-void
-DN(P_ node) { DEBUG_PRINT_NODE(node); }
-
-#endif /* GRAN */
-\end{code}
-
-
-%****************************************************************************
-%
-\subsection[qp-profile]{Quasi-Parallel Profiling}
-%
-%****************************************************************************
-
-\begin{code}
-#ifndef GRAN
-I_ do_qp_prof;
-FILE *qp_file;
-
-/* *Virtual* Time in milliseconds */
-long
-qp_elapsed_time()
-{
- return ((long) (usertime() * 1e3));
-}
-
-static void
-init_qp_profiling(STG_NO_ARGS)
-{
- I_ i;
- char qp_filename[STATS_FILENAME_MAXLEN];
-
- sprintf(qp_filename, QP_FILENAME_FMT, prog_argv[0]);
- if ((qp_file = fopen(qp_filename,"w")) == NULL ) {
- fprintf(stderr, "Can't open quasi-parallel profile report file %s\n",
- qp_filename);
- do_qp_prof = 0;
- } else {
- fputs(prog_argv[0], qp_file);
- for(i = 1; prog_argv[i]; i++) {
- fputc(' ', qp_file);
- fputs(prog_argv[i], qp_file);
- }
- fprintf(qp_file, "+RTS -C%ld -t%ld\n", contextSwitchTime, MaxThreads);
- fputs(time_str(), qp_file);
- fputc('\n', qp_file);
- }
-}
-
-void
-QP_Event0(tid, node)
-I_ tid;
-P_ node;
-{
- fprintf(qp_file, "%lu ** %lu 0x%lx\n", qp_elapsed_time(), tid, INFO_PTR(node));
-}
-
-void
-QP_Event1(event, tso)
-char *event;
-P_ tso;
-{
- fprintf(qp_file, "%lu %s %lu 0x%lx\n", qp_elapsed_time(), event,
- TSO_ID(tso), (W_) TSO_NAME(tso));
-}
-
-void
-QP_Event2(event, tso1, tso2)
-char *event;
-P_ tso1, tso2;
-{
- fprintf(qp_file, "%lu %s %lu 0x%lx %lu 0x%lx\n", qp_elapsed_time(), event,
- TSO_ID(tso1), (W_) TSO_NAME(tso1), TSO_ID(tso2), (W_) TSO_NAME(tso2));
-}
-#endif /* 0 */
-#endif /* GRAN */
-
-#if defined(CONCURRENT) && !defined(GRAN)
-/* romoluSnganpu' SamuS! */
-
-unsigned CurrentProc = 0;
-W_ IdleProcs = ~0l, Idlers = 32;
-
-void
-GranSimAllocate(n,node,liveness)
-I_ n;
-P_ node;
-W_ liveness;
-{ }
-
-void
-GranSimUnallocate(n,node,liveness)
-W_ n;
-P_ node;
-W_ liveness;
-{ }
-
-
-void
-GranSimExec(ariths,branches,loads,stores,floats)
-W_ ariths,branches,loads,stores,floats;
-{ }
-
-I_
-GranSimFetch(node /* , liveness_mask */ )
-P_ node;
-/* I_ liveness_mask; */
-{ }
-
-void
-GranSimSpark(local,node)
-W_ local;
-P_ node;
-{ }
-
-#if 0
-void
-GranSimSparkAt(spark,where,identifier)
-sparkq spark;
-P_ where; /* This should be a node; alternatively could be a GA */
-I_ identifier;
-{ }
-#endif
-
-void
-GranSimBlock()
-{ }
-#endif
-
-\end{code}