yap-6.3/C/gprof.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
*									 *
*************************************************************************/


/** @defgroup Tick_Profiler Tick Profiler
@ingroup Profiling
@{

The tick profiler works by interrupting the Prolog code every so often
and checking at each point the code was. The profiler must be able to
retrace the state of the abstract machine at every moment. The major
advantage of this approach is that it gives the actual amount of time
being spent per procedure, or whether garbage collection dominates
execution time. The major drawback is that tracking down the state of
the abstract machine may take significant time, and in the worst case
may slow down the whole execution.

The following procedures are available:

+ profinit 


Initialise the data-structures for the profiler. Unnecessary for
dynamic profiler.

+ profon 


Start profiling.

+ profoff 


Stop profiling.

 
*/

#ifdef SCCS
static char     SccsId[] = "%W% %G%";
#endif

#if defined(__x86_64__) && defined (__linux__)

#define __USE_GNU

#include <ucontext.h>

typedef greg_t context_reg;
#define CONTEXT_PC(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[14])
#define CONTEXT_BP(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[6])

#elif defined(__i386__) && defined (__linux__)


#include <ucontext.h>

typedef greg_t context_reg;
#define CONTEXT_PC(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[14])
#define CONTEXT_BP(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[6])

#elif defined(__APPLE__) && defined(__x86_64__)

#include <AvailabilityMacros.h>
#include <sys/ucontext.h>

#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
#define CONTEXT_REG(r) r
#else
#define CONTEXT_REG(r) __##r
#endif

#define CONTEXT_STATE(scv) (((ucontext_t *)(scv))->uc_mcontext->CONTEXT_REG(ss))
#define CONTEXT_PC(scv) (CONTEXT_STATE(scv).CONTEXT_REG(rip))
#define CONTEXT_BP(scv) (CONTEXT_STATE(scv).CONTEXT_REG(rbp))

#elif defined(__APPLE__) && defined(__i386__)

#include <AvailabilityMacros.h>
#include <sys/ucontext.h>

#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
#define CONTEXT_REG(r) r
#else
#define CONTEXT_REG(r) __##r
#endif

#define CONTEXT_STATE(scv) (((ucontext_t *)(scv))->uc_mcontext->CONTEXT_REG(ss))
#define CONTEXT_PC(scv) (CONTEXT_STATE(scv).CONTEXT_REG(eip))
#define CONTEXT_BP(scv) (CONTEXT_STATE(scv).CONTEXT_REG(ebp))
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)

#else

#define CONTEXT_PC(scv) NULL
#define CONTEXT_BP(scv) NULL
#ifdef LOW_PROF
#undef LOW_PROF
#endif

#endif

#include "absmi.h"
#include <stdio.h>

#if HAVE_STRING_H
#include <string.h>
#endif

#ifdef LOW_PROF
#include <signal.h>
#include <unistd.h>
#include <sys/time.h>
#ifdef __APPLE__
#else
#ifdef UCONTEXT_H
#include <ucontext.h>
#endif
#endif



#define TIMER_DEFAULT 100
#define PROFILING_FILE 1
#define PROFPREDS_FILE 2

typedef struct {
  char tag;
  void *ptr;
}  __attribute__ ((packed)) buf_ptr;

typedef struct {
  gprof_info inf;
  void  *end;
  PredEntry *pe;
}  __attribute__ ((packed))  buf_extra;

typedef struct RB_red_blk_node {
  yamop *key; /* first address */
  yamop *lim; /* end address */
  PredEntry *pe; /* parent predicate */
  gprof_info source; /* how block was allocated */
  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 *
RBMalloc(UInt size)
{
  return (rb_red_blk_node *)malloc(size);
}

static void
RBfree(rb_red_blk_node *ptr)
{
  free((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=GLOBAL_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->source=GPROF_NO_EVENT;;
  temp = RBMalloc(sizeof(rb_red_blk_node));
  temp->parent=temp->left=temp->right=GLOBAL_ProfilerNil;
  temp->key=temp->lim=NULL;
  temp->pe=NULL;
  temp->source=GPROF_NO_EVENT;
  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* rb_nil=GLOBAL_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 != rb_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(!GLOBAL_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* rb_nil=GLOBAL_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 (rb_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(!GLOBAL_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* rb_nil=GLOBAL_ProfilerNil;
  
  z->left=z->right=rb_nil;
  y=GLOBAL_ProfilerRoot;
  x=GLOBAL_ProfilerRoot->left;
  while( x != rb_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 == GLOBAL_ProfilerRoot) ||
       (y->key > z->key)) { /* y.key > z.key */
    y->left=z;
  } else {
    y->right=z;
  }

#ifdef DEBUG_ASSERT
  Assert(!GLOBAL_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);
      } 
    }
  }
  GLOBAL_ProfilerRoot->left->red=0;
  return newNode;

#ifdef DEBUG_ASSERT
  Assert(!GLOBAL_ProfilerNil->red,"nil not red in RBTreeInsert");
  Assert(!GLOBAL_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* rb_nil=GLOBAL_ProfilerNil;

  if (!GLOBAL_ProfilerRoot) return NULL;
  x=GLOBAL_ProfilerRoot->left;
  if (x == rb_nil) return NULL;
  while(x->key != q) {/*assignemnt*/
    if (x->key > q) { /* x->key > q */
      x=x->left;
    } else {
      x=x->right;
    }
    if ( x == rb_nil) return NULL;
  }
  return(x);
}


static rb_red_blk_node*
RBLookup(yamop *entry) {
  rb_red_blk_node *current;

  if (!GLOBAL_ProfilerRoot)
    return NULL;
  current = GLOBAL_ProfilerRoot->left;
  while (current != GLOBAL_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=GLOBAL_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* rb_nil=GLOBAL_ProfilerNil;
  rb_red_blk_node* root=GLOBAL_ProfilerRoot;

  if (rb_nil != (y = x->right)) { /* assignment to y is intentional */
    while(y->left != rb_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(rb_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* rb_nil=GLOBAL_ProfilerNil;
  rb_red_blk_node* root=GLOBAL_ProfilerRoot;

  y= ((z->left == rb_nil) || (z->right == rb_nil)) ? z : TreeSuccessor(z);
  x= (y->left == rb_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 (GLOBAL_DIRNAME!=NULL) free(GLOBAL_DIRNAME);
      GLOBAL_DIRNAME=malloc(size);
      if (GLOBAL_DIRNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); }
      strcpy(GLOBAL_DIRNAME,name);
    } 
    if (GLOBAL_DIRNAME==NULL) {
      do {
        if (GLOBAL_DIRNAME!=NULL) free(GLOBAL_DIRNAME);
        size+=20;
        GLOBAL_DIRNAME=malloc(size);
        if (GLOBAL_DIRNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); }
      } while (getcwd(GLOBAL_DIRNAME, size-15)==NULL); 
    }

return GLOBAL_DIRNAME;
}

char *profile_names(int);
char *profile_names(int k) {
  static char *FNAME=NULL;
  int size=200;
   
  if (GLOBAL_DIRNAME==NULL) set_profile_dir(NULL);
  size=strlen(GLOBAL_DIRNAME)+40;
  if (FNAME!=NULL) free(FNAME);
  FNAME=malloc(size);
  if (FNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); }
  strcpy(FNAME,GLOBAL_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 (GLOBAL_DIRNAME!=NULL) {
    remove(profile_names(PROFPREDS_FILE));
    remove(profile_names(PROFILING_FILE));
  }
}

void
Yap_inform_profiler_of_clause__(void *code_start, void *code_end, PredEntry *pe,gprof_info index_code) {
  buf_ptr b;
  buf_extra e;
  GLOBAL_ProfOn = TRUE;
  b.tag = '+';
  b.ptr= code_start;
  e.inf= index_code;
  e.end= code_end;
  e.pe= pe;
  fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
  fwrite(&e,sizeof(e),1,GLOBAL_FPreds);
  GLOBAL_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 profend( USES_REGS1 ); 

static void
clean_tree(rb_red_blk_node* node) {
  if (node == GLOBAL_ProfilerNil)
    return;
  clean_tree(node->left);
  clean_tree(node->right);
  Yap_FreeCodeSpace((char *)node);
}

static void
reset_tree(void) {
  clean_tree(GLOBAL_ProfilerRoot);
  Yap_FreeCodeSpace((char *)GLOBAL_ProfilerNil);
  GLOBAL_ProfilerNil = GLOBAL_ProfilerRoot = NULL;
  GLOBAL_ProfCalls = GLOBAL_ProfGCs = GLOBAL_ProfHGrows = GLOBAL_ProfSGrows = GLOBAL_ProfMallocs = GLOBAL_ProfOns = 0L;
}

static int
InitProfTree(void)
{
  if (GLOBAL_ProfilerRoot) 
    reset_tree();
  while (!(GLOBAL_ProfilerRoot = RBTreeCreate())) {
    if (!Yap_growheap(FALSE, 0, NULL)) {
      Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "while initialisating profiler");
      return FALSE;
    }    
  }
  return TRUE;
}

static void RemoveCode(CODEADDR clau)
{
  rb_red_blk_node* x, *node;
  PredEntry *pp;
  UInt count;

  if (!GLOBAL_ProfilerRoot) return;
  if (!(x = RBExactQuery((yamop *)clau))) {
    /* send message */
    GLOBAL_ProfOn = FALSE;
    return;
  }
  pp = x->pe;
  count = x->pcs;
  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 */
    GLOBAL_ProfOn = FALSE;
    return;
  } else {
    node->pcs += count;
  }  
}

static int
showprofres( USES_REGS1 ) { 
  buf_ptr buf;

  profend( PASS_REGS1 ); /* Make sure profiler has ended */

  /* First part: Read information about predicates and store it on yap trail */

  InitProfTree();
  GLOBAL_ProfGCs=0;
  GLOBAL_ProfMallocs=0;
  GLOBAL_ProfHGrows=0;
  GLOBAL_ProfSGrows=0;
  GLOBAL_ProfIndexing=0;
  GLOBAL_FProf=fopen(profile_names(PROFILING_FILE),"r"); 
  if (GLOBAL_FProf==NULL) { fclose(GLOBAL_FProf); return FALSE; }
  while (fread(&buf, sizeof(buf), 1, GLOBAL_FProf)) {
    switch (buf.tag) {
    case '+':
      {
	rb_red_blk_node *node;
	buf_extra e;

	if (fread(&e,sizeof(buf_extra),1,GLOBAL_FProf) == 0)
	  return FALSE;;
	node = RBTreeInsert(buf.ptr, e.end);
	node->pe = e.pe;
	node->source = e.inf;
	node->pcs = 0;
      }
      break;
    case '?':
      {
	prolog_exec_mode md;

	md = (prolog_exec_mode)buf.ptr;
	if (md & GCMode) {
	  GLOBAL_ProfGCs++;
	} else if (md & MallocMode) {
	  GLOBAL_ProfMallocs++;
	} else if (md & GrowHeapMode) {
	  GLOBAL_ProfHGrows++;
	} else if (md & GrowStackMode) {
	  GLOBAL_ProfSGrows++;
	}
      }
      break;
    case '-':
      RemoveCode(buf.ptr);
      break;
    default:
      {
	rb_red_blk_node *node;

	node = RBLookup(buf.ptr);
	if (!node) {
#if DEBUG
	  fprintf(stderr,"Oops: %p\n", buf.ptr);
#endif
	} else {
	  switch(node->source) {
	  case GPROF_INDEX:
	  case GPROF_INDEX_EXPAND:
	  case GPROF_LU_INDEX:
	  case GPROF_STATIC_INDEX:
	  case GPROF_INIT_EXPAND:
	  case GPROF_INIT_LOG_UPD_CLAUSE:
	  case GPROF_NEW_LU_SWITCH:
	  case GPROF_NEW_STATIC_SWITCH:
	  case GPROF_NEW_EXPAND_BLOCK:
	    GLOBAL_ProfIndexing++;
	    break;
	  default:
	    break;
	  }
	  node->pcs++; 
	}
      }
    }
  }
  fclose(GLOBAL_FProf);
  if (GLOBAL_ProfCalls==0) 
    return TRUE;
  return TRUE;
}


#define TestMode (GCMode | GrowHeapMode | GrowStackMode | ErrorHandlingMode | InErrorMode | AbortMode | MallocMode)


static void
prof_alrm(int signo, siginfo_t *si, void *scv)
{ 
  CACHE_REGS
  void * oldpc;
  yamop *current_p;
  buf_ptr b;

  GLOBAL_ProfCalls++;
  /* skip an interrupt */
  if (GLOBAL_ProfOn) {
    GLOBAL_ProfOns++;
    return;
  }
  GLOBAL_ProfOn = TRUE;
  oldpc = (void *) CONTEXT_PC(scv);
  if (LOCAL_PrologMode & TestMode) {

    b.tag = '?';
    b.ptr= (void *)LOCAL_PrologMode;
    fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
    GLOBAL_ProfOn = FALSE;
    return;
  }
  
  if (oldpc>(void *) &Yap_absmi && oldpc <= (void *) &Yap_absmiEND) { 
    CACHE_REGS
    /* we are running emulator code */
#if BP_FREE
    current_p =(yamop *) CONTEXT_BP(scv);
#else
    current_p = P;
#endif
  } else {
    CACHE_REGS
    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)->y_u.Osbpp.p->CodeOfPred;
    } else if ((oop = Yap_op_from_opcode(P->opc)) == _execute_cpred) {
      /* doing C-code */
      current_p = P->y_u.pp.p->CodeOfPred;
    } else {
      current_p = P;
    }
  }

#if !USE_SYSTEM_MALLOC
  if (P < (yamop *)Yap_HeapBase || P > (yamop *)HeapTop) {
#if DEBUG
    fprintf(stderr,"Oops: %p, %p\n", oldpc, current_p);
#endif
    GLOBAL_ProfOn = FALSE;
    return;
  }
#endif

  b.tag = '.';
  b.ptr= current_p;
  fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
  GLOBAL_ProfOn = FALSE;
}


void
Yap_InformOfRemoval(void *clau)
{
  GLOBAL_ProfOn = TRUE;
  if (GLOBAL_FPreds != NULL) {
    /* just store info about what is going on  */
    buf_ptr b;
    
    b.tag = '-';
    b.ptr= clau;
    fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
    GLOBAL_ProfOn = FALSE;
    return;
  }
  GLOBAL_ProfOn = FALSE;
}

static Int profend( USES_REGS1 ); 

static Int
profnode( USES_REGS1 ) {
  Term t1 = Deref(ARG1), tleft, tright;
  rb_red_blk_node *node;

  if (!GLOBAL_ProfilerRoot)
    return FALSE;
  if (!(node = (rb_red_blk_node *)IntegerOfTerm(t1)))
    node = GLOBAL_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 == GLOBAL_ProfilerNil) {
    tleft = TermNil;
  } else {
    tleft = MkIntegerTerm((Int)node->left);
  }
  if (node->left == GLOBAL_ProfilerNil) {
    tleft = TermNil;
  } else {
    tleft = MkIntegerTerm((Int)node->left);
  }
  if (node->right == GLOBAL_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( USES_REGS1 ) {
  return 
    Yap_unify(ARG1,MkIntegerTerm(GLOBAL_ProfCalls)) &&
    Yap_unify(ARG2,MkIntegerTerm(GLOBAL_ProfGCs)) &&
    Yap_unify(ARG3,MkIntegerTerm(GLOBAL_ProfHGrows)) &&
    Yap_unify(ARG4,MkIntegerTerm(GLOBAL_ProfSGrows)) &&
    Yap_unify(ARG5,MkIntegerTerm(GLOBAL_ProfMallocs)) &&
    Yap_unify(ARG6,MkIntegerTerm(GLOBAL_ProfIndexing)) &&
    Yap_unify(ARG7,MkIntegerTerm(GLOBAL_ProfOns)) ;
}

static Int
do_profinit( USES_REGS1 )
{
  //    GLOBAL_FPreds=fopen(profile_names(PROFPREDS_FILE),"w+"); 
  // if (GLOBAL_FPreds == NULL) return FALSE;
  GLOBAL_FProf=fopen(profile_names(PROFILING_FILE),"w+"); 
  if (GLOBAL_FProf==NULL) { fclose(GLOBAL_FProf); return FALSE; }
  GLOBAL_FPreds = GLOBAL_FProf;

  Yap_dump_code_area_for_profiler();
  return TRUE;
}

static Int profinit( USES_REGS1 )
{
  if (GLOBAL_ProfilerOn!=0) return (FALSE);
  
  if (!do_profinit( PASS_REGS1 ))
    return FALSE;

  GLOBAL_ProfilerOn = -1; /* Inited but not yet started */
  return(TRUE);
}

static Int start_profilers(int msec)
{
  struct itimerval t;
  struct sigaction sa;
  
  if (GLOBAL_ProfilerOn!=-1) {
    return FALSE; /* have to go through profinit */
  }
  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);

  GLOBAL_ProfilerOn = msec;
  return TRUE;
}


static Int profoff( USES_REGS1 ) {
  if (GLOBAL_ProfilerOn>0) {
    struct itimerval t;
    t.it_interval.tv_sec=0;
    t.it_interval.tv_usec=0;
    t.it_value.tv_sec=0;
    t.it_value.tv_usec=0;

    setitimer(ITIMER_PROF,&t,NULL);
    GLOBAL_ProfilerOn = -1;
    return TRUE;
  }
  return FALSE;
}

static Int ProfOn( USES_REGS1 ) { 
  Term p;
  profoff( PASS_REGS1 );
  p=Deref(ARG1);
  return(start_profilers(IntOfTerm(p)));
}

static Int ProfOn0( USES_REGS1 ) { 
  profoff( PASS_REGS1 );
  return(start_profilers(TIMER_DEFAULT));
}

static Int profison( USES_REGS1 ) {
  return (GLOBAL_ProfilerOn > 0);
}

static Int profalt( USES_REGS1 ) { 
  if (GLOBAL_ProfilerOn==0) return(FALSE);
  if (GLOBAL_ProfilerOn==-1) return ProfOn( PASS_REGS1 );
  return profoff( PASS_REGS1 );
}

static Int profend( USES_REGS1 ) 
{
  if (GLOBAL_ProfilerOn==0) return(FALSE);
  profoff( PASS_REGS1 );         /* Make sure profiler is off */
  GLOBAL_ProfilerOn=0;
  fclose(GLOBAL_FProf);
  GLOBAL_FPreds = NULL;
  return TRUE;
}

static Int getpredinfo( USES_REGS1 ) 
{
  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 profres0( USES_REGS1 ) { 
  return(showprofres( PASS_REGS1 ));
}

#endif /* LOW_PROF */

void
Yap_InitLowProf(void)
{
#if LOW_PROF
  GLOBAL_ProfCalls = 0;
  GLOBAL_ProfilerOn = FALSE;

  Yap_InitCPred("profinit",0, profinit, SafePredFlag);
  Yap_InitCPred("profend" ,0, profend, SafePredFlag);
  Yap_InitCPred("profon" , 0, ProfOn0, SafePredFlag);
  Yap_InitCPred("profoff", 0, profoff, SafePredFlag);
  Yap_InitCPred("profalt", 0, profalt, SafePredFlag);
  Yap_InitCPred("$offline_showprofres", 0, profres0, SafePredFlag);
  Yap_InitCPred("$profnode", 6, profnode, SafePredFlag);
  Yap_InitCPred("$profglobs", 7, profglobs, SafePredFlag);
  Yap_InitCPred("$profison",0 , profison, SafePredFlag);
  Yap_InitCPred("$get_pred_pinfo", 4, getpredinfo, SafePredFlag);
  Yap_InitCPred("showprofres", 4, getpredinfo, SafePredFlag);
#endif
}


/**
@}
*/