1387 lines
37 KiB
C
1387 lines
37 KiB
C
/*************************************************************************
|
||
* *
|
||
* 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: 2008-03-26 14:37:07 $,$Author: vsc $ *
|
||
* $Log: not supported by cvs2svn $
|
||
* Revision 1.9 2007/10/08 23:02:15 vsc
|
||
* minor fixes
|
||
*
|
||
* Revision 1.8 2007/04/10 22:13:20 vsc
|
||
* fix max modules limitation
|
||
*
|
||
* Revision 1.7 2006/08/22 16:12:45 vsc
|
||
* global variables
|
||
*
|
||
* Revision 1.6 2006/08/07 18:51:44 vsc
|
||
* fix garbage collector not to try to garbage collect when we ask for large
|
||
* chunks of stack in a single go.
|
||
*
|
||
* Revision 1.5 2006/04/27 20:58:59 rslopes
|
||
* fix do profiler offline.
|
||
*
|
||
* Revision 1.4 2006/02/01 13:28:56 vsc
|
||
* bignum support fixes
|
||
*
|
||
* Revision 1.3 2006/01/17 14:10:40 vsc
|
||
* YENV may be an HW register (breaks some tabling code)
|
||
* All YAAM instructions are now brackedted, so Op introduced an { and EndOp introduces an }. This is because Ricardo assumes that.
|
||
* Fix attvars when COROUTING is undefined.
|
||
*
|
||
* Revision 1.2 2005/12/23 00:20:13 vsc
|
||
* updates to gprof
|
||
* support for __POWER__
|
||
* Try to saveregs before longjmp.
|
||
*
|
||
* Revision 1.1 2005/12/17 03:26:38 vsc
|
||
* move event profiler outside from stdpreds.c
|
||
* *
|
||
*************************************************************************/
|
||
|
||
#ifdef SCCS
|
||
static char SccsId[] = "%W% %G%";
|
||
#endif
|
||
|
||
#include "absmi.h"
|
||
|
||
#if HAVE_STRING_H
|
||
#include <string.h>
|
||
#endif
|
||
|
||
#ifdef LOW_PROF
|
||
#include <signal.h>
|
||
#include <unistd.h>
|
||
#include <sys/time.h>
|
||
#ifdef __APPLE__
|
||
#include <sys/ucontext.h>
|
||
#else
|
||
#include <ucontext.h>
|
||
#endif
|
||
|
||
static Int ProfCalls, ProfGCs, ProfHGrows, ProfSGrows, ProfMallocs, ProfOn, ProfOns;
|
||
|
||
#define TIMER_DEFAULT 100
|
||
#define MORE_INFO_FILE 1
|
||
#define PROFILING_FILE 1
|
||
#define PROFPREDS_FILE 2
|
||
|
||
static char *DIRNAME=NULL;
|
||
|
||
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;
|
||
}
|
||
|
||
/* This is code originally written by Emin Martinian */
|
||
|
||
/***********************************************************************/
|
||
/* 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 NULL;
|
||
while(x->key != q) {/*assignemnt*/
|
||
if (x->key > q) { /* x->key > q */
|
||
x=x->left;
|
||
} else {
|
||
x=x->right;
|
||
}
|
||
if ( x == nil) return NULL;
|
||
}
|
||
return(x);
|
||
}
|
||
|
||
|
||
static rb_red_blk_node*
|
||
RBLookup(yamop *entry) {
|
||
rb_red_blk_node *current;
|
||
|
||
if (!ProfilerRoot)
|
||
return NULL;
|
||
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
|
||
}
|
||
|
||
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++;
|
||
ProfOn = TRUE;
|
||
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");
|
||
}
|
||
ProfOn = FALSE;
|
||
}
|
||
|
||
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;
|
||
PredEntry *mype;
|
||
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 %p\n",&oldpc, &pc_ptr,&mype) >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<73> um call_cpred(%p) \n",y->u.Osbpp.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(t2<pr && t2->pp==t->pp) {
|
||
calls+=t2->pcs;
|
||
t2++;
|
||
}
|
||
while(t<t2) {
|
||
t->pca=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);
|
||
if (myp->ModuleOfPred) 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 (t<pr && t->pp == 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(t2<pr && t2->pp==t->pp && t2->ts<0) {
|
||
t++;
|
||
calls+=t->pcs;
|
||
t2++;
|
||
}
|
||
printf("IDX");
|
||
} else {
|
||
printf(" ");
|
||
}
|
||
count+=calls;
|
||
// printf("%p %p",t->pp, t->beg);
|
||
if (t->pp->ModuleOfPred) 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;
|
||
}
|
||
|
||
|
||
#define TestMode (GCMode | GrowHeapMode | GrowStackMode | ErrorHandlingMode | InErrorMode | AbortMode | MallocMode)
|
||
|
||
#ifdef __APPLE__
|
||
#include <sys/ucontext.h>
|
||
|
||
#if MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
|
||
#define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->ss)
|
||
#define CONTEXT_PC (CONTEXT_STATE.eip)
|
||
#define CONTEXT_BP (CONTEXT_STATE.ebp)
|
||
#else
|
||
#define CONTEXT_STATE (((ucontext_t *)scv)->uc_mcontext->__ss)
|
||
#define CONTEXT_PC (CONTEXT_STATE.__eip)
|
||
#define CONTEXT_BP (CONTEXT_STATE.__ebp)
|
||
#endif
|
||
|
||
#endif
|
||
|
||
static void
|
||
prof_alrm(int signo, siginfo_t *si, void *scv)
|
||
{
|
||
|
||
#ifdef __linux__
|
||
ucontext_t *sc = (ucontext_t *)scv;
|
||
#if (defined(i386) || defined(__amd64__))
|
||
void * oldpc=(void *) sc->uc_mcontext.gregs[14]; /* 14= REG_EIP */
|
||
#else
|
||
void * oldpc= NULL;
|
||
#endif
|
||
#else
|
||
#ifdef __APPLE__
|
||
#ifdef __darwin__
|
||
ucontext_t *sc = (ucontext_t *)scv;
|
||
void * oldpc=(void *) sc->uc_mcontext->ss.srr0; /* 14= POWER PC */
|
||
#else
|
||
void * oldpc=(void *) CONTEXT_PC;
|
||
#endif
|
||
#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 *) ((CELL)Yap_PrologMode & TestMode), P);
|
||
ProfOn = FALSE;
|
||
return;
|
||
}
|
||
|
||
if (Yap_PrologMode & GCMode) {
|
||
ProfGCs++;
|
||
ProfOn = FALSE;
|
||
return;
|
||
}
|
||
|
||
if (Yap_PrologMode & MallocMode) {
|
||
ProfMallocs++;
|
||
ProfOn = FALSE;
|
||
return;
|
||
}
|
||
|
||
if (Yap_PrologMode & GrowHeapMode) {
|
||
ProfHGrows++;
|
||
ProfOn = FALSE;
|
||
return;
|
||
}
|
||
|
||
if (Yap_PrologMode & GrowStackMode) {
|
||
ProfSGrows++;
|
||
ProfOn = FALSE;
|
||
return;
|
||
}
|
||
|
||
}
|
||
|
||
|
||
if (oldpc>(void *) &Yap_absmi && oldpc <= (void *) &Yap_absmiEND) {
|
||
/* we are running emulator code */
|
||
#if BP_FREE
|
||
#ifdef __APPLE__
|
||
current_p =(yamop *) CONTEXT_BP;
|
||
#else
|
||
current_p =(yamop *) sc->uc_mcontext.gregs[6]; /* 6= REG_EBP */
|
||
#endif
|
||
#else
|
||
current_p = P;
|
||
#endif
|
||
} else {
|
||
op_numbers oop = Yap_op_from_opcode(PREVOP(P,Osbpp)->opc);
|
||
|
||
if (oop == _call_cpred || oop == _call_usercpred) {
|
||
/* doing C-code */
|
||
current_p = PREVOP(P,Osbpp)->u.Osbpp.p->CodeOfPred;
|
||
} else {
|
||
current_p = P;
|
||
}
|
||
}
|
||
|
||
if (P < (yamop *)Yap_HeapBase || P > (yamop *)HeapTop) {
|
||
#if DEBUG
|
||
fprintf(stderr,"Oops: %p, %p\n", oldpc, current_p);
|
||
#endif
|
||
return;
|
||
}
|
||
|
||
if (Yap_OffLineProfiler) {
|
||
fprintf(FProf,"%p %p ", oldpc, current_p);
|
||
ProfOn = FALSE;
|
||
// return;
|
||
}
|
||
|
||
if (ProfOn) {
|
||
ProfOns++;
|
||
return;
|
||
}
|
||
ProfOn = TRUE;
|
||
if ((node = RBLookup((yamop *)current_p))) {
|
||
node->pcs++;
|
||
if (Yap_OffLineProfiler) fprintf(FProf,"%p\n", node->pe);
|
||
ProfOn = FALSE;
|
||
return;
|
||
} else {
|
||
PredEntry *pp = NULL;
|
||
CODEADDR start, end;
|
||
|
||
pp = Yap_PredEntryForCode(current_p, FIND_PRED_FROM_ANYWHERE, &start, &end);
|
||
if (Yap_OffLineProfiler) fprintf(FProf,"%p\n", pp);
|
||
if (!pp) {
|
||
#if DEBUG
|
||
fprintf(stderr,"lost %p, %d\n", P, Yap_op_from_opcode(P->opc));
|
||
#endif
|
||
/* lost profiler event !! */
|
||
ProfOn=FALSE;
|
||
return;
|
||
}
|
||
/* add this clause as new node to the tree */
|
||
if (start < (CODEADDR)Yap_HeapBase || start > (CODEADDR)HeapTop ||
|
||
end < (CODEADDR)Yap_HeapBase || end > (CODEADDR)HeapTop) {
|
||
#if DEBUG
|
||
fprintf(stderr,"Oops2: %p, %p\n", start, end);
|
||
#endif
|
||
return;
|
||
}
|
||
if (pp->ArityOfPE > 100) {
|
||
#if DEBUG
|
||
fprintf(stderr,"%p:%p(%d)-->%p\n",oldpc,current_p,Yap_op_from_opcode(current_p->opc),pp);
|
||
#endif
|
||
return;
|
||
}
|
||
node = RBTreeInsert((yamop *)start, (yamop *)end);
|
||
node->pe = pp;
|
||
node->pcs = 1;
|
||
}
|
||
ProfOn = FALSE;
|
||
}
|
||
|
||
|
||
void
|
||
Yap_InformOfRemoval(CODEADDR clau)
|
||
{
|
||
rb_red_blk_node* x, *node;
|
||
UInt count;
|
||
PredEntry *pp;
|
||
|
||
if (FPreds != NULL) {
|
||
/* ricardo? */
|
||
/* do something */
|
||
return;
|
||
}
|
||
if (!ProfilerRoot) return;
|
||
ProfOn = TRUE;
|
||
if (!(x = RBExactQuery((yamop *)clau))) {
|
||
/* send message */
|
||
ProfOn = FALSE;
|
||
return;
|
||
}
|
||
/* just keep within the other profiler for now */
|
||
pp = x->pe;
|
||
count = x->pcs;
|
||
/* fprintf(stderr,"D %p:%p\n",x,pp); */
|
||
RBDelete(x);
|
||
/* use a single node to represent all deleted clauses */
|
||
if (!(node = RBExactQuery((yamop *)(pp->OpcodeOfPred)))) {
|
||
node = RBTreeInsert((yamop *)(pp->OpcodeOfPred), NEXTOP((yamop *)(pp->OpcodeOfPred),e));
|
||
node->lim = (yamop *)pp;
|
||
node->pe = pp;
|
||
node->pcs = count;
|
||
/* send message */
|
||
ProfOn = FALSE;
|
||
return;
|
||
} else {
|
||
node->pcs += count;
|
||
}
|
||
ProfOn = FALSE;
|
||
}
|
||
|
||
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 = ProfOns = 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->key)
|
||
fprintf(stderr,"%p: %p,%p,%d,%p(%d),%p,%p\n",node,node->key,node->lim,node->pcs,node->pe,node->pe->ArityOfPE,node->right,node->left);
|
||
*/
|
||
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)) &&
|
||
Yap_unify(ARG6,MkIntegerTerm(ProfOns)) ;
|
||
}
|
||
|
||
static Int
|
||
do_profinit(void)
|
||
{
|
||
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();
|
||
while (!(ProfilerRoot = RBTreeCreate())) {
|
||
if (!Yap_growheap(FALSE, 0, NULL)) {
|
||
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "while initialisating profiler");
|
||
return FALSE;
|
||
}
|
||
}
|
||
}
|
||
return TRUE;
|
||
}
|
||
|
||
static Int profinit(void)
|
||
{
|
||
if (ProfilerOn!=0) return (FALSE);
|
||
|
||
if (!do_profinit())
|
||
return FALSE;
|
||
|
||
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) {
|
||
if (Yap_OffLineProfiler) {
|
||
return FALSE; /* have to go through profinit */
|
||
} else {
|
||
if (!do_profinit())
|
||
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 profison(void) {
|
||
return (ProfilerOn > 0);
|
||
}
|
||
|
||
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 = TermProlog;
|
||
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("profinit",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", 6, profglobs, SafePredFlag);
|
||
Yap_InitCPred("$profison",0 , profison, SafePredFlag);
|
||
Yap_InitCPred("$get_pred_pinfo", 4, getpredinfo, SafePredFlag);
|
||
Yap_InitCPred("showprofres", 4, getpredinfo, SafePredFlag);
|
||
#endif
|
||
}
|