From 8996daa7c8a03569ba174ad827c9cafbdac48e84 Mon Sep 17 00:00:00 2001 From: vsc Date: Sat, 17 Dec 2005 03:26:38 +0000 Subject: [PATCH] move event profiler outside from stdpreds.c git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1478 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/gprof.c | 1249 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1249 insertions(+) create mode 100644 C/gprof.c diff --git a/C/gprof.c b/C/gprof.c new file mode 100644 index 000000000..1bc18b164 --- /dev/null +++ b/C/gprof.c @@ -0,0 +1,1249 @@ +/************************************************************************* +* * +* YAP Prolog * +* * +* Yap Prolog was developed at NCCUP - Universidade do Porto * +* * +* Copyright R. Lopes,L.Damas, V. Santos Costa and Universidade do Porto 1985-- * +* * +************************************************************************** +* * +* File: gprof.c * +* comments: Interrupt Driven Profiler * +* * +* Last rev: $Date: 2005-12-17 03:26:38 $,$Author: vsc $ * +* $Log: not supported by cvs2svn $ * +*************************************************************************/ + +#ifdef SCCS +static char SccsId[] = "%W% %G%"; +#endif + +#include "absmi.h" + +#if HAVE_STRING_H +#include +#endif + +#ifdef LOW_PROF +#include +#include +#include +#include + +Int ProfCalls, ProfGCs, ProfHGrows, ProfSGrows, ProfMallocs; + +#define TIMER_DEFAULT 100 +#define MORE_INFO_FILE 1 +#define PROFILING_FILE 1 +#define PROFPREDS_FILE 2 + +static char *DIRNAME=NULL; + +char *set_profile_dir(char *); +char *set_profile_dir(char *name){ +int size=0; + + if (name!=NULL) { + size=strlen(name)+1; + if (DIRNAME!=NULL) free(DIRNAME); + DIRNAME=malloc(size); + if (DIRNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); } + strcpy(DIRNAME,name); + } + if (DIRNAME==NULL) { + do { + if (DIRNAME!=NULL) free(DIRNAME); + size+=20; + DIRNAME=malloc(size); + if (DIRNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); } + } while (getcwd(DIRNAME, size-15)==NULL); + } + +return DIRNAME; +} + +char *profile_names(int); +char *profile_names(int k) { +static char *FNAME=NULL; +int size=200; + + if (DIRNAME==NULL) set_profile_dir(NULL); + size=strlen(DIRNAME)+40; + if (FNAME!=NULL) free(FNAME); + FNAME=malloc(size); + if (FNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); } + strcpy(FNAME,DIRNAME); + + if (k==PROFILING_FILE) { + sprintf(FNAME,"%s/PROFILING_%d",FNAME,getpid()); + } else { + sprintf(FNAME,"%s/PROFPREDS_%d",FNAME,getpid()); + } + + // printf("%s\n",FNAME); + return FNAME; +} + +void del_profile_files(void); +void del_profile_files() { + if (DIRNAME!=NULL) { + remove(profile_names(PROFPREDS_FILE)); + remove(profile_names(PROFILING_FILE)); + } +} + +void +Yap_inform_profiler_of_clause(yamop *code_start, yamop *code_end, PredEntry *pe,int index_code) { +static Int order=0; + + ProfPreds++; + if (FPreds != NULL) { + Int temp; + order++; + if (index_code) temp=-order; else temp=order; + fprintf(FPreds,"+%p %p %p %ld",code_start,code_end, pe, (long int)temp); +#if MORE_INFO_FILE + if (pe->FunctorOfPred->KindOfPE==47872) { + if (pe->ArityOfPE) { + fprintf(FPreds," %s/%d", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE); + } else { + fprintf(FPreds," %s",RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE); + } + } +#endif + fprintf(FPreds,"\n"); + } +} + +typedef struct clause_entry { + yamop *beg, *end; + PredEntry *pp; + UInt pcs; /* counter with total for each clause */ + UInt pca; /* counter with total for each predicate (repeated for each clause)*/ + int ts; /* start end timestamp towards retracts, eventually */ +} clauseentry; + +static int +cl_cmp(const void *c1, const void *c2) +{ + const clauseentry *cl1 = (const clauseentry *)c1; + const clauseentry *cl2 = (const clauseentry *)c2; + if (cl1->beg > cl2->beg) return 1; + if (cl1->beg < cl2->beg) return -1; + return 0; +} + +static int +p_cmp(const void *c1, const void *c2) +{ + const clauseentry *cl1 = (const clauseentry *)c1; + const clauseentry *cl2 = (const clauseentry *)c2; + if (cl1->pp > cl2->pp) return 1; + if (cl1->pp < cl2->pp) return -1; + + /* else same pp, but they are always different on the ts */ + if (cl1->ts > cl2->ts) return 1; + else return -1; +} + +static clauseentry * +search_pc_pred(yamop *pc_ptr,clauseentry *beg, clauseentry *end) { + Int i, j, f, l; + f = 0; l = (end-beg); + i = l/2; + while (TRUE) { + if (beg[i].beg > pc_ptr) { + l = i-1; + if (l < f) { + return NULL; + } + j = i; + i = (f+l)/2; + } else if (beg[i].end < pc_ptr) { + f = i+1; + if (f > l) { + return NULL; + } + i = (f+l)/2; + } else if (beg[i].beg <= pc_ptr && beg[i].end >= pc_ptr) { + return (&beg[i]); + } else { + return NULL; + } + } +} + +extern void Yap_InitAbsmi(void); +extern int rational_tree_loop(CELL *pt0, CELL *pt0_end, CELL **to_visit0); + +static Int profend(void); + +static int +showprofres(UInt type) { + clauseentry *pr, *t, *t2; + UInt count=0, ProfCalls=0, InGrowHeap=0, InGrowStack=0, InGC=0, InError=0, InUnify=0, InCCall=0; + yamop *pc_ptr,*y; void *oldpc; + + profend(); /* Make sure profiler has ended */ + + /* First part: Read information about predicates and store it on yap trail */ + + FPreds=fopen(profile_names(PROFPREDS_FILE),"r"); + + if (FPreds == NULL) { printf("Sorry, profiler couldn't find PROFPREDS file. \n"); return FALSE; } + + ProfPreds=0; + pr=(clauseentry *) TR; + while (fscanf(FPreds,"+%p %p %p %d",&(pr->beg),&(pr->end),&(pr->pp),&(pr->ts)) > 0){ + int c; + pr->pcs = 0L; + pr++; + if (pr > (clauseentry *)Yap_TrailTop - 1024) { + Yap_growtrail(64 * 1024L, FALSE); + } + ProfPreds++; + + do { + c=fgetc(FPreds); + } while(c!=EOF && c!='\n'); + } + fclose(FPreds); + if (ProfPreds==0) return(TRUE); + + qsort((void *)TR, ProfPreds, sizeof(clauseentry), cl_cmp); + + /* Second part: Read Profiling to know how many times each predicate has been profiled */ + + FProf=fopen(profile_names(PROFILING_FILE),"r"); + if (FProf==NULL) { printf("Sorry, profiler couldn't find PROFILING file. \n"); return FALSE; } + + t2=NULL; + ProfCalls=0; + while(fscanf(FProf,"%p %p\n",&oldpc, &pc_ptr) >0){ + if (type<10) ProfCalls++; + + if (oldpc!=0 && type<=2) { + if ((unsigned long)oldpc< 70000) { + if ((unsigned long) oldpc & GrowHeapMode) { InGrowHeap++; continue; } + if ((unsigned long)oldpc & GrowStackMode) { InGrowStack++; continue; } + if ((unsigned long)oldpc & GCMode) { InGC++; continue; } + if ((unsigned long)oldpc & (ErrorHandlingMode | InErrorMode)) { InError++; continue; } + } + if (oldpc>(void *) rational_tree_loop && oldpc<(void *) Yap_InitAbsmi) { InUnify++; continue; } + y=(yamop *) ((long) pc_ptr-20); + if (y->opc==Yap_opcode(_call_cpred) || y->opc==Yap_opcode(_call_usercpred)) { + InCCall++; /* I Was in a C Call */ + pc_ptr=y; + /* + printf("Aqui está um call_cpred(%p) \n",y->u.sla.sla_u.p->cs.f_code); + for(i=0;i<_std_top && pc_ptr->opc!=Yap_ABSMI_OPCODES[i];i++); + printf("Outro syscall diferente %s\n", Yap_op_names[i]); + */ + continue; + } + /* I should never get here, but since I'm, it is certanly Unknown Code, so + continue running to try to count it as Prolog Code */ + } + + t=search_pc_pred(pc_ptr,(clauseentry *)TR,pr); + if (t!=NULL) { /* pc was found */ + if (type<10) t->pcs++; + else { + if (t->pp==(PredEntry *)type) { + ProfCalls++; + if (t2!=NULL) t2->pcs++; + } + } + t2=t; + } + + } + + fclose(FProf); + if (ProfCalls==0) return(TRUE); + + /*I have the counting by clauses, but we also need them by predicate */ + qsort((void *)TR, ProfPreds, sizeof(clauseentry), p_cmp); + t = (clauseentry *)TR; + while (t < pr) { + UInt calls=t->pcs; + + t2=t+1; + while(t2pp==t->pp) { + calls+=t2->pcs; + t2++; + } + while(tpca=calls; + t++; + } + } + + /* counting done: now it is time to present the results */ + fflush(stdout); + + /* + if (type>10) { + PredEntry *myp = (PredEntry *)type; + if (myp->FunctorOfPred->KindOfPE==47872) { + printf("Details on predicate:"); + printf(" %s",RepAtom(AtomOfTerm(myp->ModuleOfPred))->StrOfAE); + printf(":%s",RepAtom(NameOfFunctor(myp->FunctorOfPred))->StrOfAE); + if (myp->ArityOfPE) printf("/%d\n",myp->ArityOfPE); + } + type=1; + } + */ + + if (type==0 || type==1 || type==3) { /* Results by predicate */ + t = (clauseentry *)TR; + while (t < pr) { + UInt calls=t->pca; + PredEntry *myp = t->pp; + + if (calls && myp->FunctorOfPred->KindOfPE==47872) { + count+=calls; + printf("%p",myp); + printf(" %s",RepAtom(AtomOfTerm(myp->ModuleOfPred))->StrOfAE); + printf(":%s",RepAtom(NameOfFunctor(myp->FunctorOfPred))->StrOfAE); + if (myp->ArityOfPE) printf("/%d",myp->ArityOfPE); + printf(" -> %lu (%3.1f%c)\n",(unsigned long int)calls,(float) calls*100/ProfCalls,'%'); + } + while (tpp == myp) t++; + } + } else { /* Results by clauses */ + t = (clauseentry *)TR; + while (t < pr) { + if (t->pca!=0 && (t->ts>=0 || t->pcs!=0) && t->pp->FunctorOfPred->KindOfPE==47872) { + UInt calls=t->pcs; + if (t->ts<0) { /* join all index entries */ + t2=t+1; + while(t2pp==t->pp && t2->ts<0) { + t++; + calls+=t->pcs; + t2++; + } + printf("IDX"); + } else { + printf(" "); + } + count+=calls; + // printf("%p %p",t->pp, t->beg); + printf(" %s",RepAtom(AtomOfTerm(t->pp->ModuleOfPred))->StrOfAE); + printf(":%s",RepAtom(NameOfFunctor(t->pp->FunctorOfPred))->StrOfAE); + if (t->pp->ArityOfPE) printf("/%d",t->pp->ArityOfPE); + printf(" -> %lu (%3.1f%c)\n",(unsigned long int)calls,(float) calls*100/ProfCalls,'%'); + } + t++; + } + } + count=ProfCalls-(count+InGrowHeap+InGrowStack+InGC+InError+InUnify+InCCall); // Falta +InCCall + if (InGrowHeap>0) printf("%p sys: GrowHeap -> %lu (%3.1f%c)\n",(void *) GrowHeapMode,(unsigned long int)InGrowHeap,(float) InGrowHeap*100/ProfCalls,'%'); + if (InGrowStack>0) printf("%p sys: GrowStack -> %lu (%3.1f%c)\n",(void *) GrowStackMode,(unsigned long int)InGrowStack,(float) InGrowStack*100/ProfCalls,'%'); + if (InGC>0) printf("%p sys: GC -> %lu (%3.1f%c)\n",(void *) GCMode,(unsigned long int)InGC,(float) InGC*100/ProfCalls,'%'); + if (InError>0) printf("%p sys: ErrorHandling -> %lu (%3.1f%c)\n",(void *) ErrorHandlingMode,(unsigned long int)InError,(float) InError*100/ProfCalls,'%'); + if (InUnify>0) printf("%p sys: Unify -> %lu (%3.1f%c)\n",(void *) UnifyMode,(unsigned long int)InUnify,(float) InUnify*100/ProfCalls,'%'); + if (InCCall>0) printf("%p sys: C Code -> %lu (%3.1f%c)\n",(void *) CCallMode,(unsigned long int)InCCall,(float) InCCall*100/ProfCalls,'%'); + if (count>0) printf("Unknown:Unknown -> %lu (%3.1f%c)\n",(unsigned long int)count,(float) count*100/ProfCalls,'%'); + printf("Total of Calls=%lu \n",(unsigned long int)ProfCalls); + + return TRUE; +} + + +typedef struct RB_red_blk_node { + yamop *key; /* first address */ + yamop *lim; /* end address */ + PredEntry *pe; /* parent predicate */ + UInt pcs; /* counter with total for each clause */ + int red; /* if red=0 then the node is black */ + struct RB_red_blk_node* left; + struct RB_red_blk_node* right; + struct RB_red_blk_node* parent; +} rb_red_blk_node; + +static rb_red_blk_node *ProfilerRoot, *ProfilerNil; + +static rb_red_blk_node * +RBMalloc(UInt size) +{ + return (rb_red_blk_node *)Yap_AllocCodeSpace(size); +} + +static void +RBfree(rb_red_blk_node *ptr) +{ + Yap_FreeCodeSpace((char *)ptr); +} + +static rb_red_blk_node * +RBTreeCreate(void) { + rb_red_blk_node* temp; + + /* see the comment in the rb_red_blk_tree structure in red_black_tree.h */ + /* for information on nil and root */ + temp=ProfilerNil= RBMalloc(sizeof(rb_red_blk_node)); + temp->parent=temp->left=temp->right=temp; + temp->pcs=0; + temp->red=0; + temp->key=temp->lim=NULL; + temp->pe=NULL; + temp = RBMalloc(sizeof(rb_red_blk_node)); + temp->parent=temp->left=temp->right=ProfilerNil; + temp->key=temp->lim=NULL; + temp->pe=NULL; + temp->pcs=0; + temp->red=0; + return temp; +} + +/***********************************************************************/ +/* FUNCTION: LeftRotate */ +/**/ +/* INPUTS: This takes a tree so that it can access the appropriate */ +/* root and nil pointers, and the node to rotate on. */ +/**/ +/* OUTPUT: None */ +/**/ +/* Modifies Input: tree, x */ +/**/ +/* EFFECTS: Rotates as described in _Introduction_To_Algorithms by */ +/* Cormen, Leiserson, Rivest (Chapter 14). Basically this */ +/* makes the parent of x be to the left of x, x the parent of */ +/* its parent before the rotation and fixes other pointers */ +/* accordingly. */ +/***********************************************************************/ + +static void +LeftRotate(rb_red_blk_node* x) { + rb_red_blk_node* y; + rb_red_blk_node* nil=ProfilerNil; + + /* I originally wrote this function to use the sentinel for */ + /* nil to avoid checking for nil. However this introduces a */ + /* very subtle bug because sometimes this function modifies */ + /* the parent pointer of nil. This can be a problem if a */ + /* function which calls LeftRotate also uses the nil sentinel */ + /* and expects the nil sentinel's parent pointer to be unchanged */ + /* after calling this function. For example, when RBDeleteFixUP */ + /* calls LeftRotate it expects the parent pointer of nil to be */ + /* unchanged. */ + + y=x->right; + x->right=y->left; + + if (y->left != nil) y->left->parent=x; /* used to use sentinel here */ + /* and do an unconditional assignment instead of testing for nil */ + + y->parent=x->parent; + + /* instead of checking if x->parent is the root as in the book, we */ + /* count on the root sentinel to implicitly take care of this case */ + if( x == x->parent->left) { + x->parent->left=y; + } else { + x->parent->right=y; + } + y->left=x; + x->parent=y; + +#ifdef DEBUG_ASSERT + Assert(!ProfilerNil->red,"nil not red in LeftRotate"); +#endif +} + + +/***********************************************************************/ +/* FUNCTION: RighttRotate */ +/**/ +/* INPUTS: This takes a tree so that it can access the appropriate */ +/* root and nil pointers, and the node to rotate on. */ +/**/ +/* OUTPUT: None */ +/**/ +/* Modifies Input?: tree, y */ +/**/ +/* EFFECTS: Rotates as described in _Introduction_To_Algorithms by */ +/* Cormen, Leiserson, Rivest (Chapter 14). Basically this */ +/* makes the parent of x be to the left of x, x the parent of */ +/* its parent before the rotation and fixes other pointers */ +/* accordingly. */ +/***********************************************************************/ + +static void +RightRotate(rb_red_blk_node* y) { + rb_red_blk_node* x; + rb_red_blk_node* nil=ProfilerNil; + + /* I originally wrote this function to use the sentinel for */ + /* nil to avoid checking for nil. However this introduces a */ + /* very subtle bug because sometimes this function modifies */ + /* the parent pointer of nil. This can be a problem if a */ + /* function which calls LeftRotate also uses the nil sentinel */ + /* and expects the nil sentinel's parent pointer to be unchanged */ + /* after calling this function. For example, when RBDeleteFixUP */ + /* calls LeftRotate it expects the parent pointer of nil to be */ + /* unchanged. */ + + x=y->left; + y->left=x->right; + + if (nil != x->right) x->right->parent=y; /*used to use sentinel here */ + /* and do an unconditional assignment instead of testing for nil */ + + /* instead of checking if x->parent is the root as in the book, we */ + /* count on the root sentinel to implicitly take care of this case */ + x->parent=y->parent; + if( y == y->parent->left) { + y->parent->left=x; + } else { + y->parent->right=x; + } + x->right=y; + y->parent=x; + +#ifdef DEBUG_ASSERT + Assert(!ProfilerNil->red,"nil not red in RightRotate"); +#endif +} + +/***********************************************************************/ +/* FUNCTION: TreeInsertHelp */ +/**/ +/* INPUTS: tree is the tree to insert into and z is the node to insert */ +/**/ +/* OUTPUT: none */ +/**/ +/* Modifies Input: tree, z */ +/**/ +/* EFFECTS: Inserts z into the tree as if it were a regular binary tree */ +/* using the algorithm described in _Introduction_To_Algorithms_ */ +/* by Cormen et al. This funciton is only intended to be called */ +/* by the RBTreeInsert function and not by the user */ +/***********************************************************************/ + +static void +TreeInsertHelp(rb_red_blk_node* z) { + /* This function should only be called by InsertRBTree (see above) */ + rb_red_blk_node* x; + rb_red_blk_node* y; + rb_red_blk_node* nil=ProfilerNil; + + z->left=z->right=nil; + y=ProfilerRoot; + x=ProfilerRoot->left; + while( x != nil) { + y=x; + if (x->key < z->key) { /* x.key > z.key */ + x=x->left; + } else { /* x,key <= z.key */ + x=x->right; + } + } + z->parent=y; + if ( (y == ProfilerRoot) || + (y->key < z->key)) { /* y.key > z.key */ + y->left=z; + } else { + y->right=z; + } + +#ifdef DEBUG_ASSERT + Assert(!ProfilerNil->red,"nil not red in TreeInsertHelp"); +#endif +} + +/* Before calling Insert RBTree the node x should have its key set */ + +/***********************************************************************/ +/* FUNCTION: RBTreeInsert */ +/**/ +/* INPUTS: tree is the red-black tree to insert a node which has a key */ +/* pointed to by key and info pointed to by info. */ +/**/ +/* OUTPUT: This function returns a pointer to the newly inserted node */ +/* which is guarunteed to be valid until this node is deleted. */ +/* What this means is if another data structure stores this */ +/* pointer then the tree does not need to be searched when this */ +/* is to be deleted. */ +/**/ +/* Modifies Input: tree */ +/**/ +/* EFFECTS: Creates a node node which contains the appropriate key and */ +/* info pointers and inserts it into the tree. */ +/***********************************************************************/ + +static rb_red_blk_node * +RBTreeInsert(yamop *key, yamop *lim) { + rb_red_blk_node * y; + rb_red_blk_node * x; + rb_red_blk_node * newNode; + + x=(rb_red_blk_node*) RBMalloc(sizeof(rb_red_blk_node)); + x->key=key; + x->lim=lim; + + TreeInsertHelp(x); + newNode=x; + x->red=1; + while(x->parent->red) { /* use sentinel instead of checking for root */ + if (x->parent == x->parent->parent->left) { + y=x->parent->parent->right; + if (y->red) { + x->parent->red=0; + y->red=0; + x->parent->parent->red=1; + x=x->parent->parent; + } else { + if (x == x->parent->right) { + x=x->parent; + LeftRotate(x); + } + x->parent->red=0; + x->parent->parent->red=1; + RightRotate(x->parent->parent); + } + } else { /* case for x->parent == x->parent->parent->right */ + y=x->parent->parent->left; + if (y->red) { + x->parent->red=0; + y->red=0; + x->parent->parent->red=1; + x=x->parent->parent; + } else { + if (x == x->parent->left) { + x=x->parent; + RightRotate(x); + } + x->parent->red=0; + x->parent->parent->red=1; + LeftRotate(x->parent->parent); + } + } + } + ProfilerRoot->left->red=0; + return newNode; + +#ifdef DEBUG_ASSERT + Assert(!ProfilerNil->red,"nil not red in RBTreeInsert"); + Assert(!ProfilerRoot->red,"root not red in RBTreeInsert"); +#endif +} + +/***********************************************************************/ +/* FUNCTION: RBExactQuery */ +/**/ +/* INPUTS: tree is the tree to print and q is a pointer to the key */ +/* we are searching for */ +/**/ +/* OUTPUT: returns the a node with key equal to q. If there are */ +/* multiple nodes with key equal to q this function returns */ +/* the one highest in the tree */ +/**/ +/* Modifies Input: none */ +/**/ +/***********************************************************************/ + +static rb_red_blk_node* +RBExactQuery(yamop* q) { + rb_red_blk_node* x; + rb_red_blk_node* nil=ProfilerNil; + + if (!ProfilerRoot) return NULL; + x=ProfilerRoot->left; + if (x == nil) return(0); + while(x->key != q) {/*assignemnt*/ + if (x->key < q) { /* x->key > q */ + x=x->left; + } else { + x=x->right; + } + if ( x == nil) return(0); + } + return(x); +} + + +static rb_red_blk_node* +RBLookup(yamop *entry) { + rb_red_blk_node *current = ProfilerRoot->left; + + while (current != ProfilerNil) { + if (current->key <= entry && current->lim >= entry) { + return current; + } + if (entry < current->key) + current = current->right; + else + current = current->left; + } + return NULL; +} + + +/***********************************************************************/ +/* FUNCTION: RBDeleteFixUp */ +/**/ +/* INPUTS: tree is the tree to fix and x is the child of the spliced */ +/* out node in RBTreeDelete. */ +/**/ +/* OUTPUT: none */ +/**/ +/* EFFECT: Performs rotations and changes colors to restore red-black */ +/* properties after a node is deleted */ +/**/ +/* Modifies Input: tree, x */ +/**/ +/* The algorithm from this function is from _Introduction_To_Algorithms_ */ +/***********************************************************************/ + +static void RBDeleteFixUp(rb_red_blk_node* x) { + rb_red_blk_node* root=ProfilerRoot->left; + rb_red_blk_node *w; + + while( (!x->red) && (root != x)) { + if (x == x->parent->left) { + w=x->parent->right; + if (w->red) { + w->red=0; + x->parent->red=1; + LeftRotate(x->parent); + w=x->parent->right; + } + if ( (!w->right->red) && (!w->left->red) ) { + w->red=1; + x=x->parent; + } else { + if (!w->right->red) { + w->left->red=0; + w->red=1; + RightRotate(w); + w=x->parent->right; + } + w->red=x->parent->red; + x->parent->red=0; + w->right->red=0; + LeftRotate(x->parent); + x=root; /* this is to exit while loop */ + } + } else { /* the code below is has left and right switched from above */ + w=x->parent->left; + if (w->red) { + w->red=0; + x->parent->red=1; + RightRotate(x->parent); + w=x->parent->left; + } + if ( (!w->right->red) && (!w->left->red) ) { + w->red=1; + x=x->parent; + } else { + if (!w->left->red) { + w->right->red=0; + w->red=1; + LeftRotate(w); + w=x->parent->left; + } + w->red=x->parent->red; + x->parent->red=0; + w->left->red=0; + RightRotate(x->parent); + x=root; /* this is to exit while loop */ + } + } + } + x->red=0; + +#ifdef DEBUG_ASSERT + Assert(!tree->nil->red,"nil not black in RBDeleteFixUp"); +#endif +} + + + +/***********************************************************************/ +/* FUNCTION: TreeSuccessor */ +/**/ +/* INPUTS: tree is the tree in question, and x is the node we want the */ +/* the successor of. */ +/**/ +/* OUTPUT: This function returns the successor of x or NULL if no */ +/* successor exists. */ +/**/ +/* Modifies Input: none */ +/**/ +/* Note: uses the algorithm in _Introduction_To_Algorithms_ */ +/***********************************************************************/ + +static rb_red_blk_node* +TreeSuccessor(rb_red_blk_node* x) { + rb_red_blk_node* y; + rb_red_blk_node* nil=ProfilerNil; + rb_red_blk_node* root=ProfilerRoot; + + if (nil != (y = x->right)) { /* assignment to y is intentional */ + while(y->left != nil) { /* returns the minium of the right subtree of x */ + y=y->left; + } + return(y); + } else { + y=x->parent; + while(x == y->right) { /* sentinel used instead of checking for nil */ + x=y; + y=y->parent; + } + if (y == root) return(nil); + return(y); + } +} + +/***********************************************************************/ +/* FUNCTION: RBDelete */ +/**/ +/* INPUTS: tree is the tree to delete node z from */ +/**/ +/* OUTPUT: none */ +/**/ +/* EFFECT: Deletes z from tree and frees the key and info of z */ +/* using DestoryKey and DestoryInfo. Then calls */ +/* RBDeleteFixUp to restore red-black properties */ +/**/ +/* Modifies Input: tree, z */ +/**/ +/* The algorithm from this function is from _Introduction_To_Algorithms_ */ +/***********************************************************************/ + +static void +RBDelete(rb_red_blk_node* z){ + rb_red_blk_node* y; + rb_red_blk_node* x; + rb_red_blk_node* nil=ProfilerNil; + rb_red_blk_node* root=ProfilerRoot; + + y= ((z->left == nil) || (z->right == nil)) ? z : TreeSuccessor(z); + x= (y->left == nil) ? y->right : y->left; + if (root == (x->parent = y->parent)) { /* assignment of y->p to x->p is intentional */ + root->left=x; + } else { + if (y == y->parent->left) { + y->parent->left=x; + } else { + y->parent->right=x; + } + } + if (y != z) { /* y should not be nil in this case */ + +#ifdef DEBUG_ASSERT + Assert( (y!=tree->nil),"y is nil in RBDelete\n"); +#endif + /* y is the node to splice out and x is its child */ + + if (!(y->red)) RBDeleteFixUp(x); + + /* tree->DestroyKey(z->key);*/ + /*tree->DestroyInfo(z->info); */ + y->left=z->left; + y->right=z->right; + y->parent=z->parent; + y->red=z->red; + z->left->parent=z->right->parent=y; + if (z == z->parent->left) { + z->parent->left=y; + } else { + z->parent->right=y; + } + RBfree(z); + } else { + /*tree->DestroyKey(y->key);*/ + /*tree->DestroyInfo(y->info);*/ + if (!(y->red)) RBDeleteFixUp(x); + RBfree(y); + } + +#ifdef DEBUG_ASSERT + Assert(!tree->nil->red,"nil not black in RBDelete"); +#endif +} + +#define TestMode (GCMode | GrowHeapMode | GrowStackMode | ErrorHandlingMode | InErrorMode | AbortMode | MallocMode) + +extern int Yap_absmiEND(void); + +static void +prof_alrm(int signo, siginfo_t *si, ucontext_t *sc) +{ +#if __linux__ +#if (defined(i386) || defined(__amd64__)) + void * oldpc=(void *) sc->uc_mcontext.gregs[14]; /* 14= REG_EIP */ +#else + void * oldpc= NULL; +#endif +#else +#if __POWERPC__ + void * oldpc=(void *) sc->uc_mcontext->ss.srr0; /* 14= POWER PC */ +#else + void *NULL; +#endif +#endif + rb_red_blk_node *node = NULL; + yamop *current_p; + + ProfCalls++; + if (Yap_PrologMode & TestMode) { + if (Yap_OffLineProfiler) { + fprintf(FProf,"%p %p\n", (void *) (Yap_PrologMode & TestMode), P); + return; + } + + if (Yap_PrologMode & GCMode) { + ProfGCs++; + return; + } + + if (Yap_PrologMode & MallocMode) { + ProfMallocs++; + return; + } + + if (Yap_PrologMode & GrowHeapMode) { + ProfHGrows++; + return; + } + + if (Yap_PrologMode & GrowStackMode) { + ProfSGrows++; + return; + } + + } + + + if (oldpc>(void *) &Yap_absmi && oldpc <= (void *) &Yap_absmiEND) { + /* we are running emulator code */ +#if BP_FREE + current_p =(yamop *) sc->uc_mcontext.gregs[6]; /* 6= REG_EBP */ +#else + current_p = P; +#endif + } else { + op_numbers oop = Yap_op_from_opcode(PREVOP(P,sla)->opc); + + if (oop == _call_cpred || oop == _call_usercpred) { + /* doing C-code */ + current_p = PREVOP(P,sla)->u.sla.sla_u.p->CodeOfPred; + } else { + current_p = P; + } + } + + if (Yap_OffLineProfiler) { + fprintf(FProf,"0 %p\n", current_p); + return; + } + if ((node = RBLookup((yamop *)current_p))) { + node->pcs++; + return; + } else { + PredEntry *pp = NULL; + CODEADDR start, end; + + pp = Yap_PredEntryForCode(current_p, FIND_PRED_FROM_ANYWHERE, &start, &end); + if (!pp) { +#if DEBUG + fprintf(stderr,"lost %p, %d\n", P, Yap_op_from_opcode(P->opc)); +#endif + /* lost profiler event !! */ + return; + } + /* add this clause as new node to the tree */ + node = RBTreeInsert((yamop *)start, (yamop *)end); + node->pe = pp; + node->pcs = 1; + } +} + + +void +Yap_InformOfRemoval(CODEADDR clau) +{ + rb_red_blk_node* x, *node; + UInt count; + PredEntry *pp; + + if (!ProfilerRoot) return; + if (!(x = RBExactQuery((yamop *)clau))) { + /* send message */ + return; + } + /* just keep within the other profiler for now */ + RBDelete(x); + pp = x->pe; + count = x->pcs; + /* use a single node to represent all deleted clauses */ + if (!(node = RBExactQuery((yamop *)pp))) { + node = RBTreeInsert((yamop *)pp, (yamop *)pp); + node->lim = (yamop *)pp; + node->pe = pp; + node->pcs = count; + /* send message */ + return; + } else { + node->pcs += count; + } +} + +static void +clean_tree(rb_red_blk_node* node) { + if (node == ProfilerNil) + return; + clean_tree(node->left); + clean_tree(node->right); + Yap_FreeCodeSpace((char *)node); +} + +static void +reset_tree(void) { + clean_tree(ProfilerRoot); + Yap_FreeCodeSpace((char *)ProfilerNil); + ProfilerNil = ProfilerRoot = NULL; + ProfCalls = ProfGCs = ProfHGrows = ProfSGrows = ProfMallocs = 0L; +} + +static Int profend(void); + +static Int +profnode(void) { + Term t1 = Deref(ARG1), tleft, tright; + rb_red_blk_node *node; + + if (!ProfilerRoot) + return FALSE; + if (!(node = (rb_red_blk_node *)IntegerOfTerm(t1))) + node = ProfilerRoot; + if (node->left == ProfilerNil) { + tleft = TermNil; + } else { + tleft = MkIntegerTerm((Int)node->left); + } + if (node->left == ProfilerNil) { + tleft = TermNil; + } else { + tleft = MkIntegerTerm((Int)node->left); + } + if (node->right == ProfilerNil) { + tright = TermNil; + } else { + tright = MkIntegerTerm((Int)node->right); + } + return + Yap_unify(ARG2,MkIntegerTerm((Int)node->key)) && + Yap_unify(ARG3,MkIntegerTerm((Int)node->pe)) && + Yap_unify(ARG4,MkIntegerTerm((Int)node->pcs)) && + Yap_unify(ARG5,tleft) && + Yap_unify(ARG6,tright); +} + +static Int +profglobs(void) { + return + Yap_unify(ARG1,MkIntegerTerm(ProfCalls)) && + Yap_unify(ARG2,MkIntegerTerm(ProfGCs)) && + Yap_unify(ARG3,MkIntegerTerm(ProfHGrows)) && + Yap_unify(ARG4,MkIntegerTerm(ProfSGrows)) && + Yap_unify(ARG5,MkIntegerTerm(ProfMallocs)); +} + +static Int profinit(void) +{ + if (ProfilerOn!=0) return (FALSE); + + + if (Yap_OffLineProfiler) { + FPreds=fopen(profile_names(PROFPREDS_FILE),"w+"); + if (FPreds == NULL) return FALSE; + FProf=fopen(profile_names(PROFILING_FILE),"w+"); + if (FProf==NULL) { fclose(FPreds); return FALSE; } + + Yap_dump_code_area_for_profiler(); + } else { + if (ProfilerRoot) + reset_tree(); + } + ProfilerOn = -1; /* Inited but not yet started */ + return(TRUE); +} + +static Int profinit1(void) +{ + Term t = Deref(ARG1); + + if (IsVarTerm(t)) { + if (Yap_OffLineProfiler) + Yap_unify(ARG1,MkAtomTerm(Yap_LookupAtom("offline"))); + else + Yap_unify(ARG1,MkAtomTerm(Yap_LookupAtom("online"))); + } else if (IsAtomTerm(t)) { + char *name = RepAtom(AtomOfTerm(t))->StrOfAE; + if (!strcmp(name,"offline")) + Yap_OffLineProfiler = TRUE; + else if (!strcmp(name,"online")) + Yap_OffLineProfiler = FALSE; + else { + Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE,t,"profinit only allows offline,online"); + return FALSE; + } + } else { + Yap_Error(TYPE_ERROR_ATOM,t,"profinit only allows offline,online"); + return FALSE; + } + return profinit(); +} + + +static Int proftype(void) +{ + if (Yap_OffLineProfiler) + return Yap_unify(ARG1,MkAtomTerm(Yap_LookupAtom("offline"))); + else + return Yap_unify(ARG1,MkAtomTerm(Yap_LookupAtom("online"))); +} + +static Int start_profilers(int msec) +{ + struct itimerval t; + struct sigaction sa; + + if (ProfilerOn!=-1) return (FALSE); /* have to go through profinit */ + + if (ProfilerRoot) + reset_tree(); + while (!(ProfilerRoot = RBTreeCreate())) { + if (!Yap_growheap(FALSE, 0, NULL)) { + Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "while initialisating profiler"); + return FALSE; + } + } + sa.sa_sigaction=prof_alrm; + sigemptyset(&sa.sa_mask); + sa.sa_flags=SA_SIGINFO; + if (sigaction(SIGPROF,&sa,NULL)== -1) return FALSE; +// if (signal(SIGPROF,prof_alrm) == SIG_ERR) return FALSE; + + t.it_interval.tv_sec=0; + t.it_interval.tv_usec=msec; + t.it_value.tv_sec=0; + t.it_value.tv_usec=msec; + setitimer(ITIMER_PROF,&t,NULL); + + ProfilerOn = msec; + return(TRUE); +} + + +static Int profon(void) { + Term p; + p=Deref(ARG1); + return(start_profilers(IntOfTerm(p))); +} + +static Int profon0(void) { + return(start_profilers(TIMER_DEFAULT)); +} + +static Int profoff(void) { + if (ProfilerOn>0) { + setitimer(ITIMER_PROF,NULL,NULL); + ProfilerOn = -1; + return TRUE; + } + return FALSE; +} + +static Int profalt(void) { + if (ProfilerOn==0) return(FALSE); + if (ProfilerOn==-1) return profon(); + return profoff(); +} + +static Int profend(void) +{ + if (ProfilerOn==0) return(FALSE); + profoff(); /* Make sure profiler is off */ + ProfilerOn=0; + + return TRUE; +} + +static Int getpredinfo(void) +{ + PredEntry *pp = (PredEntry *)IntegerOfTerm(Deref(ARG1)); + Term mod, name; + UInt arity; + + if (!pp) + return FALSE; + if (pp->ModuleOfPred == PROLOG_MODULE) + mod = ModuleName[0]; + else + mod = pp->ModuleOfPred; + if (pp->ModuleOfPred == IDB_MODULE) { + if (pp->PredFlags & NumberDBPredFlag) { + arity = 0; + name = MkIntegerTerm(pp->src.IndxId); + } else if (pp->PredFlags & AtomDBPredFlag) { + arity = 0; + name = MkAtomTerm((Atom)pp->FunctorOfPred); + } else { + name = MkAtomTerm(NameOfFunctor(pp->FunctorOfPred)); + arity = ArityOfFunctor(pp->FunctorOfPred); + } + } else { + arity = pp->ArityOfPE; + if (pp->ArityOfPE) { + name = MkAtomTerm(NameOfFunctor(pp->FunctorOfPred)); + } else { + name = MkAtomTerm((Atom)(pp->FunctorOfPred)); + } + } + return Yap_unify(ARG2, mod) && + Yap_unify(ARG3, name) && + Yap_unify(ARG4, MkIntegerTerm(arity)); +} + +static Int profres(void) { + Term p; + p=Deref(ARG1); + if (IsLongIntTerm(p)) return(showprofres(LongIntOfTerm(p))); + else return(showprofres(IntOfTerm(p))); +} + +static Int profres0(void) { + return(showprofres(0)); +} + +#endif /* LOW_PROF */ + +void +Yap_InitLowProf(void) +{ +#if LOW_PROF + ProfCalls = 0; + ProfilerOn = FALSE; + Yap_OffLineProfiler = FALSE; + Yap_InitCPred("profinit",0, profinit, SafePredFlag); + Yap_InitCPred("profini1",1, profinit1, SafePredFlag); + Yap_InitCPred("$proftype",1, proftype, SafePredFlag); + Yap_InitCPred("profend" ,0, profend, SafePredFlag); + Yap_InitCPred("profon" , 0, profon0, SafePredFlag); + Yap_InitCPred("profon" , 1, profon, SafePredFlag); + Yap_InitCPred("profoff", 0, profoff, SafePredFlag); + Yap_InitCPred("profalt", 0, profalt, SafePredFlag); + Yap_InitCPred("$offline_showprofres", 0, profres0, SafePredFlag); + Yap_InitCPred("$offline_showprofres", 1, profres, SafePredFlag); + Yap_InitCPred("$profnode", 6, profnode, SafePredFlag); + Yap_InitCPred("$profglobs", 5, profglobs, SafePredFlag); + Yap_InitCPred("$get_pred_pinfo", 4, getpredinfo, SafePredFlag); + Yap_InitCPred("showprofres", 4, getpredinfo, SafePredFlag); +#endif +}