/*=====================================================================*/
/*    serrano/prgm/project/bigloo/bdb/blib/gc_dump.c                   */
/*    -------------------------------------------------------------    */
/*    Author      :  Manuel Serrano                                    */
/*    Creation    :  Tue Aug  3 10:13:43 1999                          */
/*    Last change :  Tue Dec  3 11:12:18 2002 (serrano)                */
/*    Copyright   :  2000-02 Manuel Serrano                            */
/*    -------------------------------------------------------------    */
/*    This file implements the scanning of the heap. That is:          */
/*     - The graphical dump of a heap. This produces a pixmap          */
/*       representing the heap. Each memory word is represented by     */
/*       one pixel in that image.                                      */
/*     - the textual statistics dumps.                                 */
/*=====================================================================*/
#define I_HIDE_POINTERS
#include <stdio.h>
#include <gc_priv.h>
#include <dbg_mlc.h>
#include <gc_backptr.h>
#include <bigloo.h>
#include "color.h"

/*---------------------------------------------------------------------*/
/*    Because we don't have to count the local allocations, we have    */
/*    to reset the allocation mark routines.                           */
/*---------------------------------------------------------------------*/
#undef BGL_HEAP_DEBUG_MARK_OBJ
#undef BGL_HEAP_DEBUG_MARK_STR
#define BGL_HEAP_DEBUG_MARK_OBJ( x ) x
#define BGL_HEAP_DEBUG_MARK_STR( x ) x

/*---------------------------------------------------------------------*/
/*    The macro that constructs a Bigloo string                        */
/*---------------------------------------------------------------------*/
#define MAKE_BSTRING( str ) SYMBOL_TO_STRING( string_to_symbol( str ) )

/*---------------------------------------------------------------------*/
/*    Exported functions.                                              */
/*---------------------------------------------------------------------*/
extern long bdb_heap_size();
extern long bdb_alloc_gc();
extern long bdb_gc_number();
extern int bdb_gc_explore( int, obj_t, int );
extern int bdb_gc_explore_offset( int, long, int );
extern int bdb_gc_dump( int, char *, int, int, int, int );
extern obj_t bdb_gc_gather_stat( int );
extern int bdb_gc_stat( int, int );
extern int bdb_set_lock();
extern int bdb_release_lock();

/*---------------------------------------------------------------------*/
/*    Importations                                                     */
/*---------------------------------------------------------------------*/
extern char *bdb_find_type( obj_t );
extern int bdb_heap_dump_send( int, obj_t );
extern void bdb_live_producer_reset();
extern void bdb_live_producer_add( char *, long );
extern obj_t bdb_live_producer_list();
extern void bdb_allocated_producer_reset();
extern void bdb_allocated_producer_add( char *, long );
extern obj_t bdb_allocated_producer_list();
extern void bgl_heap_debug_mark_hooks_set( void (*o)(), void (*b)() );
extern obj_t create_vector( int );

/*---------------------------------------------------------------------*/
/*    Local functions and variables                                    */
/*---------------------------------------------------------------------*/
static void heap_count_types();
static void object_count_type();
static void reset_live_counters();
static void reset_alloc_counters();
static void sort_type_counters();
static void (*object_count_type_hook)( void *, char *, char *, long );

/*---------------------------------------------------------------------*/
/*    locked_bdb_hook ...                                              */
/*    -------------------------------------------------------------    */
/*    This lock is set to 1 in order to prevent bdb allocation to      */
/*    be gathered.                                                     */
/*---------------------------------------------------------------------*/
static char locked_bdb_hook = 0;

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_set_lock ...                                                 */
/*    -------------------------------------------------------------    */
/*    This function is also directly called by the Bigloo emitted      */
/*    code. It is used to unlock debugging when module initialization  */
/*    is complete.                                                     */
/*    @label bdb_set_lock@ ...                                         */
/*---------------------------------------------------------------------*/
int
bdb_set_lock() {
   locked_bdb_hook++;
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_release_lock ...                                             */
/*    -------------------------------------------------------------    */
/*    This function is also directly called by the Bigloo emitted      */
/*    code. It is used to lock debugging before module are             */
/*    completly initialized.                                           */
/*    @label bdb_release_lock@ ...                                     */
/*---------------------------------------------------------------------*/
int
bdb_release_lock() {
   locked_bdb_hook--;
}
   
/*---------------------------------------------------------------------*/
/*    Type counting.                                                   */
/*---------------------------------------------------------------------*/
/* The maxium number of types an application may use */
#define MAX_CLIENT_TYPES 1024
/* the maximum number of types, Bdb can handle */
#define MAX_BDB_TYPES (MAX_CLIENT_TYPES + 1)
/* the maximum number of types to be distinguished in the heap dump */
#define MAX_TYPE_COLORS 32

/* the string size part of the type name that will be used to */
/* represent the percentage of use of the type                */
#define PERCENT_LEN (6)

static long type_counters[ MAX_BDB_TYPES ];
static long type_acounters[ MAX_BDB_TYPES ];
static long type_sizes[ MAX_BDB_TYPES ];
static long type_asizes[ MAX_BDB_TYPES ];
static char type_colors[ MAX_BDB_TYPES ];
static int color_to_type[ MAX_BDB_TYPES ];
static char *type_names[ MAX_BDB_TYPES ];
static long object_number, aobject_number = 0;
static long object_size, aobject_size = 0;
static long other_number, other_size;

/*---------------------------------------------------------------------*/
/*    Dump modes                                                       */
/*---------------------------------------------------------------------*/
#define DUMP_REFERENCES   -1
#define DUMP_GENERATIONS  -2
#define DUMP_TYPES        -3

/*---------------------------------------------------------------------*/
/*    Strings allocation file                                          */
/*---------------------------------------------------------------------*/
#define OH_FUNCTION( x ) \
   (SYMBOLP( x ) ? \
     BSTRING_TO_STRING( SYMBOL_TO_STRING( x ) ) : \
     "BDB:SYSTEM")

#define BDB_PREFIX "BDB:"
#define STRING_ALLOC_FILE "Clib/cstring.c"

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    gc_make_pair ...                                                 */
/*    -------------------------------------------------------------    */
/*    Because there is no guaranty that MAKE_PAIR calls can be         */
/*    nested, we use our local function.                               */
/*---------------------------------------------------------------------*/
static obj_t
gc_make_pair( obj_t car, obj_t cdr ) {
   return MAKE_PAIR( car, cdr );
}

/*---------------------------------------------------------------------*/
/*    OH_TO_OBJ ...                                                    */
/*    -------------------------------------------------------------    */
/*    Convert an OH object into a Bigloo object.                       */
/*---------------------------------------------------------------------*/
#define OH_TO_OBJ( _oh ) (((obj_t)((((oh *)(_oh)))+1)))

/*---------------------------------------------------------------------*/
/*    Local configuration                                              */
/*---------------------------------------------------------------------*/
int max_type_colors = MAX_TYPE_COLORS;

/*---------------------------------------------------------------------*/
/*    Local buffer                                                     */
/*---------------------------------------------------------------------*/
static char root_base_buf[ 20 ];

/*---------------------------------------------------------------------*/
/*    static int                                                       */
/*    the_leak_culprit_size ...                                        */
/*---------------------------------------------------------------------*/
static int the_leak_culprit_size = ALIGNMENT_VALUE;

/*---------------------------------------------------------------------*/
/*    static int                                                       */
/*    leak_culprit_size ...                                            */
/*---------------------------------------------------------------------*/
static int
leak_culprit_size() {
   return the_leak_culprit_size;
}

/*---------------------------------------------------------------------*/
/*    void *                                                           */
/*    leak_culprit_addr ...                                            */
/*    -------------------------------------------------------------    */
/*    The address of the root that makes the leak.                     */
/*---------------------------------------------------------------------*/
void *
leak_culprit_addr( void *current ) {
   void *base;
   size_t offset;
   GC_ref_kind source;
   void *gc_addr = GC_base( current );

   source = GC_get_back_ptr_info( gc_addr, &base, &offset );

   switch( source ) {
      case GC_UNREFERENCED:
	 the_leak_culprit_size = ALIGNMENT_VALUE;
	 return 0L;
	 
      case GC_NO_SPACE:
	 the_leak_culprit_size = ALIGNMENT_VALUE;
	 return 0L;
	    
      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
	 the_leak_culprit_size = GC_size( gc_addr );
	 return current;
	 
      case GC_FINALIZER_REFD:
	 the_leak_culprit_size = GC_size( gc_addr );
	 return current;
	 
      case GC_REFD_FROM_HEAP: {
	 return leak_culprit_addr( GC_base( base ) );
      }
   }
}
   
/*---------------------------------------------------------------------*/
/*    static void *                                                    */
/*    GC_get_offset_addr ...                                           */
/*    -------------------------------------------------------------    */
/*    Find an address in the heap located at [heap_offset] from the    */
/*    heap starting address.                                           */
/*---------------------------------------------------------------------*/
static void *
GC_get_offset_addr( long heap_offset ) {
   int i;
   
   for( i = 0; i < GC_n_heap_sects; i++ ) {
      int size = GC_heap_sects[ i ].hs_bytes;
      if( heap_offset < size ) {
	 return GC_base( GC_heap_sects[ i ].hs_start + heap_offset );
      } else {
	 heap_offset -= size;
      }
   }
   
   return 0;
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    get_reference_pixel_color ...                                    */
/*---------------------------------------------------------------------*/
static int
get_reference_pixel_color( void *addr, int hide_bdb ) {
   size_t      offset = 0;
   void       *base = 0;
   void       *gc_addr;
   GC_ref_kind kind;
   void       *heap_offset = (void *)((unsigned long)addr & (~TAG_MASK));
   char       *s;

   gc_addr = GC_base( addr );
   s = (char *)((oh *)gc_addr)->oh_string;
   kind = GC_get_back_ptr_info( gc_addr, &base, &offset );

   if( hide_bdb &&
       (!SYMBOLP( s ) || !strncmp( OH_FUNCTION( s ), BDB_PREFIX, 4 ) ) ) {
      return INVISIBLE_CHAR_COLOR;
   }
   
   switch( kind ) {
      case GC_UNREFERENCED:
	 return INVISIBLE_CHAR_COLOR;
	 
      case GC_NO_SPACE:
	 return CHAR_COLOR1;

      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
	 return CHAR_COLOR2;
	 
      case GC_REFD_FROM_HEAP:
	 return CHAR_COLOR3;

      case GC_FINALIZER_REFD:
	 return CHAR_COLOR4;
   }
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    get_generation_pixel_color ...                                   */
/*---------------------------------------------------------------------*/
static int
get_generation_pixel_color( void *addr, int hide_bdb ) {
   size_t      offset = 0;
   void       *base = 0;
   void       *gc_addr;
   GC_ref_kind kind;
   void       *heap_offset = (void *)((unsigned long)addr & (~TAG_MASK));

   gc_addr = GC_base( addr );
   kind = GC_get_back_ptr_info( gc_addr, &base, &offset );

   switch( kind ) {
      case GC_UNREFERENCED:
	 return INVISIBLE_CHAR_COLOR;
	 
      case GC_NO_SPACE:
	 return CHAR_COLOR1;

      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
      case GC_REFD_FROM_HEAP:
      case GC_FINALIZER_REFD: {
	 int age = ((((oh *)gc_addr)->oh_int & ~0xffff) >> 16);
	 char *s = (char *)((oh *)gc_addr)->oh_string;

	 if( hide_bdb &&
	     (!SYMBOLP( s ) || !strncmp( OH_FUNCTION(s), BDB_PREFIX, 4 ) ) ) {
	    return INVISIBLE_CHAR_COLOR;
	 }
	 
	 switch ( GC_gc_no - age ) {
		  
	    case 1:
	       /* 1 gc old */
	       return CHAR_COLOR3;
	       
	    case 2:
	       /* 2 gc old */
	       return CHAR_COLOR4;
	       
	    case 3:
	    case 4:
	    case 5:
	       /* 3-5 gc old */
	       return CHAR_COLOR5;

	    case 6:
	    case 7:
	    case 8:
	    case 9:
	    case 10:
	       /* 6-10 gc old */
	       return CHAR_COLOR6;

	    default:
	       /* very old */
	       return CHAR_COLOR7;
	 }
      }
   }
}

/*---------------------------------------------------------------------*/
/*    static int                                                       */
/*    leak_gc_num ...                                                  */
/*---------------------------------------------------------------------*/
static int leak_gc_num = 0;

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    get_leak_pixel_color ...                                         */
/*---------------------------------------------------------------------*/
static int
get_leak_pixel_color( void *addr, int hide_bdb ) {
   size_t      offset = 0;
   void       *base = 0;
   void       *gc_addr;
   GC_ref_kind kind;
   void       *heap_offset = (void *)((unsigned long)addr & (~TAG_MASK));

   gc_addr = GC_base( addr );
   kind = GC_get_back_ptr_info( gc_addr, &base, &offset );

   switch( kind ) {
      case GC_UNREFERENCED:
      case GC_NO_SPACE:
	 return INVISIBLE_CHAR_COLOR;

      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
      case GC_REFD_FROM_HEAP:
      case GC_FINALIZER_REFD: {
	 obj_t tobj = OH_TO_OBJ( gc_addr );
	 hdr *hhdr = GC_find_header( (ptr_t)tobj );
	 int type = TYPE( tobj );
	 oh *o = gc_addr;
	 char *s = (char *)o->oh_string;
	 int age = ((((oh *)gc_addr)->oh_int & ~0xffff) >> 16);

	 if( hide_bdb &&
	     (!SYMBOLP( s ) || !strncmp( OH_FUNCTION(s), BDB_PREFIX, 4 ) ) )
	    return INVISIBLE_CHAR_COLOR;

	 return ( age >= leak_gc_num ) ? LEAK_CHAR : INVISIBLE_CHAR_COLOR;
      }
   }
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    get_type_pixel_color ...                                         */
/*---------------------------------------------------------------------*/
static int
get_type_pixel_color( void *addr, int hide_bdb ) {
   size_t      offset = 0;
   void       *base = 0;
   void       *gc_addr;
   GC_ref_kind kind;
   void       *heap_offset = (void *)((unsigned long)addr & (~TAG_MASK));

   gc_addr = GC_base( addr );
   kind = GC_get_back_ptr_info( gc_addr, &base, &offset );

   switch( kind ) {
      case GC_UNREFERENCED:
      case GC_NO_SPACE:
	 return INVISIBLE_CHAR_COLOR;

      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
      case GC_REFD_FROM_HEAP:
      case GC_FINALIZER_REFD: {
	 obj_t tobj = OH_TO_OBJ( gc_addr );
	 hdr *hhdr = GC_find_header( (ptr_t)tobj );
	 int type = TYPE( tobj );
	 oh *o = gc_addr;
	 char *s = (char *)o->oh_string;

	 if( hide_bdb &&
	     (!SYMBOLP( s ) || !strncmp( OH_FUNCTION(s), BDB_PREFIX, 4 ) ) )
	    return INVISIBLE_CHAR_COLOR;

	 return type_colors[ hhdr->hb_obj_kind ? type : MAX_CLIENT_TYPES ];
      }
   }
}

/*---------------------------------------------------------------------*/
/*    long                                                             */
/*    address_to_offset ...                                            */
/*    -------------------------------------------------------------    */
/*    From an [address] in the heap return the corresponding offset.   */
/*    -------------------------------------------------------------    */
/*    This function is the inverse of [GC_get_offset_addr].            */
/*---------------------------------------------------------------------*/
long
address_to_offset( void *addr ) {
   int i;
   long heap_offset = 0;
   char *caddr = addr;
   
   for( i = 0; i < GC_n_heap_sects; i++ ) {
      int size = GC_heap_sects[ i ].hs_bytes;
      char *start = (char *)GC_base( GC_heap_sects[ i ].hs_start );
			     
      if( (start <= caddr) && ((start + size) > caddr) )
	 return (heap_offset + (caddr - start)) / ALIGNMENT_VALUE;
      else
	 heap_offset += size;
   }
   
   return -1;
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    set_pixel_culprit_color ...                                      */
/*    -------------------------------------------------------------    */
/*    In the file FOUT, change the pixel color the be the color of a   */
/*    leak root.                                                       */
/*---------------------------------------------------------------------*/
void
set_pixel_culprit_color( FILE *fout,
			 long fpos,
			 int width,
			 void *culprit_addr,
			 char color ) {
   long delta = address_to_offset( culprit_addr );

   if( delta >= 0 ) {
      long lnum  = delta / width;
      long cnum  = delta % width;
      /* to get the correct char pos, we have to add 4 ('"' + '"' + ','   */
      /* + '\n' for each line that we must skip, plus 1 ('"') for the     */
      /* beginning of the current line.                                   */
      long char_pos = delta + 1 + (lnum * 4) + fpos;
      int size = leak_culprit_size();
      fseek( fout, char_pos, SEEK_SET );

      while( size > 0 ) {
	 if( cnum == width ) {
	    /* we have to jump over one line end */
	    fseek( fout, 4, SEEK_CUR );
	    cnum = 1;
	 } else
	    cnum++;
	 
	 size -= ALIGNMENT_VALUE;
	 fputc( color, fout );
      }
   }
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_gc_sectors_list ...                                         */
/*    -------------------------------------------------------------    */
/*    Make a Bigloo list of strings that is composed of the GC         */
/*    sectors description. We use strings instead of number is order   */
/*    to avoid Bigloo arithmetic limitations.                          */
/*---------------------------------------------------------------------*/
static obj_t
make_gc_sectors_list( int i ) {
   return BNIL;
/*    if( i == GC_n_heap_sects )                                       */
/*       return BNIL;                                                  */
/*    else {                                                           */
/*       char addr1[ 20 ], addr2[ 20 ];                                */
/*       sprintf( addr1, "%ld", GC_heap_sects[ i ].hs_start );         */
/*       sprintf( addr2, "%ld", GC_heap_sects[ i ].hs_bytes );         */
/*       return gc_make_pair( gc_make_pair( MAKE_BSTRING( addr1 ),      */
/* 				   MAKE_BSTRING( addr2 ) ),       */
/* 			make_gc_sectors_list( i + 1 ) );               */
/*    }                                                                */
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_legend_references ...                                       */
/*---------------------------------------------------------------------*/
static obj_t
make_legend_references( long leak_size ) {
   return
      gc_make_pair(
	 make_gc_sectors_list( 0 ),
	 gc_make_pair(
	    BINT( leak_size ),
	    gc_make_pair( 
	       MAKE_BSTRING( "Reference" ),
	       gc_make_pair( 
		  gc_make_pair( MAKE_BSTRING( COLOR0 ),
			     MAKE_BSTRING( "Free" ) ),
		  gc_make_pair( 
		     gc_make_pair( MAKE_BSTRING( COLOR1 ),
				MAKE_BSTRING( "Unreferenced" ) ),
		     gc_make_pair( 
			gc_make_pair( MAKE_BSTRING( COLOR2 ),
				   MAKE_BSTRING( "Undebugged" ) ),
			gc_make_pair( 
			   gc_make_pair( MAKE_BSTRING( COLOR3 ),
				      MAKE_BSTRING( "Root" ) ),
			   gc_make_pair( 
			      gc_make_pair( MAKE_BSTRING( COLOR4 ),
					 MAKE_BSTRING( "Heap" ) ),
			      gc_make_pair( 
				 gc_make_pair( MAKE_BSTRING( COLOR5 ),
					    MAKE_BSTRING( "Finalizer" ) ),
				 BNIL ) ) ) ) ) ) ) ) );
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_legend_generations ...                                      */
/*---------------------------------------------------------------------*/
static obj_t
make_legend_generations( long leak_size ) {
   return
      gc_make_pair(
	 make_gc_sectors_list( 0 ),
	 gc_make_pair(
	    BINT( leak_size ),
	    gc_make_pair(
	       MAKE_BSTRING( "Age (in GCs)" ),
	       gc_make_pair( 
		  gc_make_pair( MAKE_BSTRING( COLOR0 ),
			     MAKE_BSTRING( "Free" ) ),
		  gc_make_pair( 
		     gc_make_pair( MAKE_BSTRING( COLOR1 ),
				MAKE_BSTRING( "Unreferenced     " ) ),
		     gc_make_pair( 
			gc_make_pair( MAKE_BSTRING( COLOR2 ),
				   MAKE_BSTRING( "Nodebugged" ) ),
			gc_make_pair( 
			   gc_make_pair( MAKE_BSTRING( COLOR3 ),
				      MAKE_BSTRING( "1" ) ),
			   gc_make_pair( 
			      gc_make_pair( MAKE_BSTRING( COLOR4 ),
					 MAKE_BSTRING( "2" ) ),
			      gc_make_pair( 
				 gc_make_pair( MAKE_BSTRING( COLOR5 ),
					    MAKE_BSTRING( "3-5" ) ),
				 gc_make_pair( 
				    gc_make_pair( MAKE_BSTRING( COLOR6 ),
					       MAKE_BSTRING( "6-10" ) ),
				    gc_make_pair( 
				       gc_make_pair( MAKE_BSTRING( COLOR7 ),
						  MAKE_BSTRING( "> 10" ) ),
				       BNIL ) ) ) ) ) ) ) ) ) ) );
}

/*---------------------------------------------------------------------*/
/*    static char *                                                    */
/*    make_one_type_legend ...                                         */
/*---------------------------------------------------------------------*/
static char *
make_one_type_legend( int color_number ) {
   int type_number = color_to_type[ color_number ];

   if( (type_number >= 0) && (object_number > 0) ) {
      char *type_name = type_names[ type_number ];
      int type_percent = (100 * type_counters[ type_number ]) / object_number;

      sprintf( &type_name[ strlen( type_name ) - (PERCENT_LEN) ],
	       " (%2d%%)", (type_percent >= 100) ? 99 : type_percent );

      return type_name;
   } else
      return "";
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_legend_types ...                                            */
/*---------------------------------------------------------------------*/
static obj_t
make_legend_types( long leak_size ) {
   obj_t pair = BNIL;
   char other[ 20 ];
   int i;

   if( object_number > 0 ) {
      /* The other types */
      sprintf( other, "OTHERS (%2d%%)",
	       (object_number ? ((100 * other_number) / object_number) : 0) );
      
      pair = gc_make_pair(
	 gc_make_pair( MAKE_BSTRING( string_colors[ max_type_colors-1 ] ),
		       string_to_bstring( other ) ),
	 BNIL );
   }

   /* the regular types */
   for( i = max_type_colors - 2; i >= 1 ; i-- ) {
      pair = gc_make_pair(
	 gc_make_pair( MAKE_BSTRING( string_colors[ i ] ),
		       MAKE_BSTRING( make_one_type_legend( i ) ) ),
	 pair );
   }

   /* The legend */
   return 
      gc_make_pair(
	 make_gc_sectors_list( 0 ),
	 gc_make_pair(
	    BINT( leak_size ),
	    gc_make_pair(
	       MAKE_BSTRING( "Type" ),
	       pair ) ) );
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_legend_default ...                                          */
/*---------------------------------------------------------------------*/
static obj_t
make_legend_default( long leak_size ) {
   return 
      gc_make_pair(
	 make_gc_sectors_list( 0 ),
	 gc_make_pair(
	    BINT( leak_size ),
	    gc_make_pair(
	       MAKE_BSTRING( "Leaks" ),
	       gc_make_pair( 
		  gc_make_pair( MAKE_BSTRING( COLOR0 ),
				MAKE_BSTRING( "No leak" ) ),
		  gc_make_pair( 
		     gc_make_pair( MAKE_BSTRING( COLOR1 ),
				   MAKE_BSTRING( "Leak" ) ),
		     gc_make_pair( 
			gc_make_pair( MAKE_BSTRING( COLOR2 ),
				      MAKE_BSTRING( "Root" ) ),
			gc_make_pair( 
			   gc_make_pair( MAKE_BSTRING( COLOR3 ),
					 MAKE_BSTRING( "Leak root" ) ),
			   BNIL ) ) ) ) ) ) );
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    make_legend ...                                                  */
/*---------------------------------------------------------------------*/
static obj_t
make_legend( int mode, long leak_size ) {
   switch( mode ) {
      case DUMP_REFERENCES:
	 return make_legend_references( leak_size );
      case DUMP_GENERATIONS:
	 return make_legend_generations( leak_size );
      case DUMP_TYPES:
	 return make_legend_types( leak_size );
      default:
	 return make_legend_default( leak_size );
   }
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    strip_to_bstring ...                                             */
/*    -------------------------------------------------------------    */
/*    Convert the stripped C string into a Bigloo string. To strip,    */
/*    we remove the percentage composant of the string.                */
/*---------------------------------------------------------------------*/
obj_t
strip_to_bstring( char *str ) {
   char *stop = strchr( str, ' ' );

   if( !stop )
      return MAKE_BSTRING( str );
   else {
      obj_t res;
      
      *stop = '\0';
      res = MAKE_BSTRING( str );
      *stop = ' ';

      return res;
   }
}      

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    make_type_vector ...                                             */
/*    -------------------------------------------------------------    */
/*    Construct a Bigloo vector. It number of entries is the           */
/*    maximum number of types used in the application. Each entry      */
/*    I is a Bigloo string which is the name of the type number I.     */
/*    -------------------------------------------------------------    */
/*    If type I has never been allocated yet, its associated entry     */
/*    is set to BFALSE.                                                */
/*---------------------------------------------------------------------*/
obj_t
make_type_vector() {
   int i, len = bgl_types_number();
   obj_t res = create_vector( len + 1 );

   for( i = 0; i < len; i++ ) {
      if( type_names[ i ] )
	 /* type already allocated */
	 VECTOR_SET( res, i, strip_to_bstring( type_names[ i ] ) );
      else
	 /* type unallocated yet */
	 VECTOR_SET( res, i, BFALSE );
   }
   
   /* the BUFFER STRING type is alwayys the last type */
   if( type_names[ MAX_CLIENT_TYPES ] )
      VECTOR_SET( res, i, strip_to_bstring( type_names[ MAX_CLIENT_TYPES ] ) );
   else
      VECTOR_SET( res, i, BFALSE );

   /* we are done with the Bigloo vector */
   return res;
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_stat_entry ...                                              */
/*---------------------------------------------------------------------*/
static obj_t
make_stat_entry( char *name,
		 long size, double szp,
		 long num, double nbp,
		 long asize, double aszp,
		 long anum, double anbp,
		 char *color ) {
   obj_t res = create_vector( 10 );
   
   /* the type name */
   VECTOR_SET( res, 0, strip_to_bstring( name ) );
   /* the overall heap size for that type */
   VECTOR_SET( res, 1, BINT( size ) );
   /* the percentage of size of the heap */
   VECTOR_SET( res, 2, DOUBLE_TO_REAL( szp ) );
   /* the number of occurrences of the type */
   VECTOR_SET( res, 3, BINT( num ) );
   /* the percentage of number of heap objects */
   VECTOR_SET( res, 4, DOUBLE_TO_REAL( nbp ) );
   /* The overall allocated size for that type */
   VECTOR_SET( res, 5, BINT( asize ) );
   /* the percentage of size of the allocation */
   VECTOR_SET( res, 6, DOUBLE_TO_REAL( aszp ) );
   /* the number of occurrences */
   VECTOR_SET( res, 7, BINT( anum ) );
   /* the percentage of num of heap obj */
   VECTOR_SET( res, 8, DOUBLE_TO_REAL( anbp ) );
   /* the color of that type */
   VECTOR_SET( res, 9, MAKE_BSTRING( color ) );

/*    printf( "aobject_size: %d KB  aobject_nmber: %d\n",              */
/* 	   aobject_size / 1024, aobject_number );                      */
/*    printf( "  name: %s size: %d num: %d asize: %d anum: %d\n",      */
/* 	   name, size, num, asize, anum );                             */
/*    dprint( res );                                                   */

   return res;
}
			 
/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    bdb_stat_heap ...                                                */
/*---------------------------------------------------------------------*/
static obj_t
bdb_stat_heap() {
   obj_t pair = BNIL;
   char name[ 80 ];
   int i;

   if( (object_number > 0) && (other_number > 0) )
      pair = gc_make_pair(
	 make_stat_entry( "Others",
			  /* size */
			  other_size / 1024,
			  /* szp */
			  (100. * (double)other_size )/(double)object_size,
			  /* num */
			  other_number,
			  /* nbp */
			  (100. * (double)other_number)/(double)object_number,
			  /* asize */
			  0,
			  /* aszp */
			  0,
			  /* anum */
			  0,
			  /* anbp */
			  0,
			  /* color */
			  string_colors[ max_type_colors-1 ] ),
	 BNIL );
   else
      pair = BNIL;

   /* the regular types */
   for( i = max_type_colors - 2; i >= 1 ; i-- ) {
      int tn = color_to_type[ i ];
      if( (tn >= 0) &&
	  ((type_counters[ tn ] > 0) || (type_acounters[ tn ] > 0)) ) {
	 double szp =
	    type_sizes[ tn ] > 0 ?
	    (100. * (double)type_sizes[ tn ]) / (double)object_size
	    : 0.0;
	 double aszp =
	    aobject_size > 0 ?
	    (100. * (double)type_asizes[ tn ]) / (double)aobject_size
	    : 0.0;
	 double nbp =
	    type_counters[ tn ] > 0 ?
	    (100. * (double)type_counters[ tn ]) / (double)object_number
	    : 0.0;
	 double anbp =
	    aobject_number > 0 ?
	    (100. * (double)type_acounters[ tn ]) / (double)aobject_number
	    : 0.0;
      
	 pair = gc_make_pair( make_stat_entry( type_names[ tn ],
					       /* size */
					       type_sizes[ tn ] / 1024,
					       /* szp */
					       szp,
					       /* num */
					       type_counters[ tn ],
					       /* nbp */
					       nbp,
					       /* asize */
					       type_asizes[ tn ] / 1024,
					       /* aszp */
					       aszp,
					       /* anum */
					       type_acounters[ tn ],
					       /* anbp */
					       anbp,
					       /* color */
					       string_colors[ i ] ),
			      pair );
      }
   } 
   
   /* The legend */
   return gc_make_pair( pair,
			gc_make_pair(
			   bdb_live_producer_list(),
			   gc_make_pair(
			      bdb_allocated_producer_list(),
			      gc_make_pair(
				 make_type_vector(),
				 BNIL ) ) ) );
}
   
/*---------------------------------------------------------------------*/
/*    static void                                                      */
/*    bdb_dump_root_leak ...                                           */
/*    -------------------------------------------------------------    */
/*    When we want to see the memory leaking we have to complete       */
/*    two traversal. The first one finds the leaks and the second      */
/*    one finds the culprit roots. The BDB_DUMP_ROOT_LEAK is the       */
/*    second traversal.                                                */
/*    -------------------------------------------------------------    */
/*    The parameter of DUMP are:                                       */
/*       FOUT: the file to be modified.                                */
/*       FPOS: the position in the file where the heap starts          */
/*       WIDTH: the horizontal width of the pixmap.                    */
/*       DEPTH: the depth of the pixmap.                               */
/*---------------------------------------------------------------------*/
static long
bdb_dump_root_leak( FILE *fout, long fpos, int width, int depth ) {
   int height;
   long heap_offset = 0;
   int line = 0, col = 0;
   long heap_size = GC_get_heap_size();
   long leak_size = 0;

   /* we scan the whole heap */
   while( heap_offset < heap_size ) {
      void *gc_addr = GC_get_offset_addr( heap_offset );

      if( !gc_addr || !GC_is_marked( gc_addr ) ) {
	 heap_offset += ALIGNMENT_VALUE;
      } else {
	 int size = GC_size( gc_addr );

	 if( get_leak_pixel_color( gc_addr, 1 ) == LEAK_CHAR ) {
	    void *culprit_addr = leak_culprit_addr( gc_addr );

	    if( culprit_addr ) {
	       int col;
	       leak_size += size;

	       if( (culprit_addr == gc_addr) ||
		   (get_leak_pixel_color( culprit_addr, 1 ) == LEAK_CHAR ) )
		  col = LEAK_ROOT_CHAR;
	       else
		  col = ROOT_CHAR;

	       set_pixel_culprit_color( fout, fpos, width, culprit_addr, col );
	    }
	 }

	 heap_offset += size;
      }
   }

   /* we go the end of the file */
   fseek( fout, 0, SEEK_END );

   /* we return the global leak size */
   return leak_size;
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    bdb_dump_heap ...                                                */
/*    -------------------------------------------------------------    */
/*    The parameter of DUMP are:                                       */
/*       FILE-NAME: the file to be produced.                           */
/*       WIDTH: the horizontal width of the pixmap.                    */
/*       DEPTH: the depth of the pixmap.                               */
/*       MODE: a flag telling how to compute the color of each cell    */
/*---------------------------------------------------------------------*/
static obj_t
bdb_dump_heap( char *fname, int width, int depth, int mode, int hide_bdb ) {
   int height;
   long heap_offset = 0;
   int line = 0, col = 0;
   long heap_size = GC_get_heap_size();
   FILE *fout;
   char *swidth = malloc( width + 1 );
   int (*f)( void *, int );
   long ftell_heap;
   long leak_size = -1;
   int rdepth = 1 << depth;
   
   max_type_colors = (rdepth <= MAX_TYPE_COLORS) ? rdepth : MAX_TYPE_COLORS;
   
   swidth[ width ] = 0;

   if( fout = fname ? fopen( fname, "w" ) : stdout ) {

      /* we compute the height of the pixmap */
      height = (heap_size / width) / ALIGNMENT_VALUE;

      /* we emit the xpm header */
      fprintf( fout, "/* XPM */\nstatic char *heap[] = {\n" );
      fprintf( fout, "/* width height num_colors chars_per_pixel */\n" );
      if( mode > 0 ) {
	 /* leak mode */
	 fprintf( fout, "\"   %d    %d     4          1\",\n", width, height );
	 fprintf( fout, "/* colors */\n" );
	 fprintf( fout, "\"%c c %s\",\n", INVISIBLE_CHAR_COLOR, COLOR0 );
	 fprintf( fout, "\"%c c %s\",\n", LEAK_CHAR, COLOR1 );
	 fprintf( fout, "\"%c c %s\",\n", LEAK_ROOT_CHAR, COLOR2 );
	 fprintf( fout, "\"%c c %s\",\n", ROOT_CHAR, COLOR3 );
	 fprintf( fout, "/* pixels */\n" );

	 /* we store the position in the file for the second traversal */
	 fflush( fout );
	 ftell_heap = ftell( fout );
      }
      else {
	 int i;
	 
	 /* regular mode */
	 fprintf( fout, "\"   %d    %d     %d          1\",\n",
		  width, height, rdepth );
	 fprintf( fout, "/* colors */\n" );
	 for( i = 0; i < rdepth; i++ ) 
	    fprintf( fout, "\"%c c %s\",\n",
		     char_colors[ i ],
		     string_colors[ i ]  );
	 fprintf( fout, "/* pixels */\n" );
      }

      /* before entering the loop we setup the get_pixel_color function */
      switch( mode ) {
	 case DUMP_REFERENCES:
	    f = get_reference_pixel_color;
	    break;
	 case DUMP_GENERATIONS:
	    f = get_generation_pixel_color;
	    break;
	 case DUMP_TYPES:
	    f = get_type_pixel_color;
	    object_count_type_hook = 0L;
	    heap_count_types( hide_bdb );
	    break;
	 default:
	    leak_gc_num = mode;
	    f = get_leak_pixel_color;
      }
	    
      /* we scan all the heap */
      while( line < height ) {
	 putc( '"', fout );
	 while( col < width ) {
	    if( heap_offset >= heap_size ) {
	       while( col++ < width )
		  swidth[ col ] = INVISIBLE_CHAR_COLOR;
	       fputs( "\",\n", fout );
	       goto done;
	    } else {
	       void *gc_addr = GC_get_offset_addr( heap_offset );

	       if( !gc_addr || !GC_is_marked( gc_addr ) ) {
		  swidth[ col++ ] = INVISIBLE_CHAR_COLOR;
		  heap_offset += ALIGNMENT_VALUE;
	       } else {
		  int size = GC_size( gc_addr );
		  int c = f( gc_addr, hide_bdb );
		  heap_offset += size;
		  while( size > 0 ) {
		     size -= ALIGNMENT_VALUE;
		     swidth[ col++ ] = (!size ? INVISIBLE_CHAR_COLOR : c);
		     if( col >= width ) {
			/* this is a premature end of line */
			fputs( swidth, fout );
			fputs( "\",\n\"", fout );
			line++;
			col = 0;
		     }
		  }
	       }
	    }
	 }
	 fputs( swidth, fout );
	 fputs( "\",\n", fout );
	 col = 0;
	 line++;
      }

   done:
      fprintf( fout, "};\"\n\n " );

      /* when producing a leak dump we have to make a second traversal */
      /*   of the heap in order to print the roots of the leaks.       */
      if( mode > 0 )
	 leak_size = bdb_dump_root_leak( fout, ftell_heap, width, depth );

      free( swidth );
      if( fname ) fclose( fout );
      return make_legend( mode, leak_size );
   }
   return BNIL;
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_gc_dump ...                                                  */
/*---------------------------------------------------------------------*/
int
bdb_gc_dump( int port, char *file, int width, int depth, int mode, int hide ) {
   obj_t legend;
   
   /* first of all, spawn a collection */
   GC_gcollect();

   /* walk the heap and build the dump */
   legend = bdb_dump_heap( file, width, depth, mode, hide );

   /* send the dump back to bdb */
   return bdb_heap_dump_send( port, legend );
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    bdb_stat_count_type_hook ...                                     */
/*    -------------------------------------------------------------    */
/*    This function is called by OBJECT_COUNT_TYPE each time a valid   */
/*    object is reached.                                               */
/*---------------------------------------------------------------------*/
void
bdb_stat_count_type_hook( void *gc_addr, char *root_base, char *s, long t ) {
   /* we store in a hash table the allocator */
   bdb_live_producer_add( s, t );
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    bdb_gc_gather_stat ...                                           */
/*    -------------------------------------------------------------    */
/*    It is mandatory in this function to change the Bigloo            */
/*    execution stat otherwise the objects allocates during the        */
/*    heap statistics gathering will be set to the Scheme              */
/*    function for which the stack frame was active when the GC        */
/*    was spawned.                                                     */
/*    -------------------------------------------------------------    */
/*    When this function is entered the bdb hook lock is assumed       */
/*    to be already held.                                              */
/*---------------------------------------------------------------------*/
obj_t
bdb_gc_gather_stat( int hide_bdb ) {
   obj_t res;

   {
      PUSH_TRACE( BUNSPEC );

      max_type_colors = MAX_TYPE_COLORS;

      bdb_live_producer_reset();
      
      object_count_type_hook = bdb_stat_count_type_hook;
      heap_count_types( hide_bdb );

      res = bdb_stat_heap();

      /* now that we have gathered the statistics, we may reset the  */
      /* allocated producers so that next GC, we'll get a clean list */
/*       reset_alloc_counters();                                       */

      POP_TRACE();
      return res;
   }
}


/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_gc_stat ...                                                  */
/*    -------------------------------------------------------------    */
/*    Computes how many objects are live in the heap and their types   */
/*    and accumulated size. Returns a list of made of this statistic   */
/*    result.                                                          */
/*    -------------------------------------------------------------    */
/*    It is mandatory in this function to change the Bigloo            */
/*    execution stat otherwise the objects allocates during the        */
/*    heap statistics gathering will be set to the Scheme              */
/*    function for which the stack frame was active when the GC        */
/*    was spawned.                                                     */
/*---------------------------------------------------------------------*/
int
bdb_gc_stat( int port, int hide_bdb ) {
   static long gc_num = -1;
   int res;

   /* get the lock to avoid accounting what will be allocated now */
   bdb_set_lock();

   if( bdb_gc_number() != gc_num ) {
      PUSH_TRACE( BUNSPEC );
      
      /* we have to run a GC in order to be sure that we have enough */
      /* free rooms to allocate what is needed by this function      */
      GC_gcollect();

      /* we mark the GC number to avoid useless recomputations */
      gc_num = bdb_gc_number();

      /* when the user requests an heap inspection, we have to reset */
      /* the allocation counting process. This is not automatically  */
      /* done one GC completion.                                     */
      res = bdb_heap_dump_send( port, bdb_gc_gather_stat( hide_bdb ) );
      
      bdb_release_lock();
      POP_TRACE();
      
      return res;
   } else {
      PUSH_TRACE( BUNSPEC );
      
      bdb_heap_dump_send( port, BFALSE );
      bdb_release_lock();
      
      POP_TRACE();
      return 0;
   }
}

/*---------------------------------------------------------------------*/
/*    long                                                             */
/*    bdb_heap_size ...                                                */
/*    -------------------------------------------------------------    */
/*    The size of the current heap in byte.                            */
/*---------------------------------------------------------------------*/
long
bdb_heap_size() {
   return (long)GC_get_heap_size();
} 

/*---------------------------------------------------------------------*/
/*    long                                                             */
/*    bdb_alloc_gc ...                                                 */
/*    -------------------------------------------------------------    */
/*    The number of allocation since the beginning of the execution.   */
/*---------------------------------------------------------------------*/
long
bdb_alloc_gc() {
   return GC_get_allocated_bytes();
}

/*---------------------------------------------------------------------*/
/*    long                                                             */
/*    bdb_gc_number ...                                                */
/*    -------------------------------------------------------------    */
/*    The number of gc executed.                                       */
/*---------------------------------------------------------------------*/
long
bdb_gc_number() {
   extern word GC_gc_no;
   return (long)GC_gc_no;
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_stop_chain ...                                              */
/*---------------------------------------------------------------------*/
static obj_t
make_stop_chain( char *s ) {
   return gc_make_pair( MAKE_BSTRING( s ), BNIL );
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    make_bstring_info ...                                            */
/*---------------------------------------------------------------------*/
static obj_t
make_bstring_info( void *current, void *base, size_t offset, int verbose ) {
   void *new_base = GC_base( base );
   oh *o = current;
   char s[ 256 ];
   void *tmp_base;
   size_t tmp_offset;
   GC_ref_kind tmp_source;
   char *type;
   hdr *hhdr;
   obj_t tobj;
	 
   tobj = OH_TO_OBJ( current );
   hhdr = GC_find_header( (ptr_t)tobj );
	 
   /* in order to request for a Bigloo identifier, we have to check */
   /* first that the object has been allocated with debug info      */
   tmp_source = GC_get_back_ptr_info( new_base, &tmp_base, &tmp_offset );

   switch( tmp_source) {
      case GC_UNREFERENCED:
	 type = "<???>";
	 break;
	 
      case GC_NO_SPACE:
	 type = "<no_space>";
	 break;
	    
      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
      case GC_FINALIZER_REFD:
      case GC_REFD_FROM_HEAP:
	 if( verbose ) {
	    printf( "make_link_chain...\n" );
	    printf( "bdb_find_type: %p\n", tobj );
	    printf( "         file: %s\n", OH_FUNCTION( o->oh_string ) );
	    printf( "         line: %d\n", o->oh_int & 0xffff);
	    printf( "          hdr: %p\n", hhdr );
	    printf( "         free: %d\n", hhdr->hb_obj_kind );
	 }
	       
	 type = hhdr->hb_obj_kind
	    ? bdb_find_type( tobj )
	    : "<STRING BUFFER>";

	 if( verbose ) {
	    printf( "         type: %s\n", type );
	 }
   }

   sprintf( s, "%p (offset: %p) [%s]", tobj, offset, type );

   return string_to_bstring( s );
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    make_root_chain ...                                              */
/*---------------------------------------------------------------------*/
obj_t
make_root_chain( void *current, void *base, size_t offset ) {
   if( GC_is_visible( current ) ) {
      obj_t tobj;
      char *type;
      hdr  *hhdr;
      char s[ 256 ];
      
      tobj = OH_TO_OBJ( current );
      type = bdb_find_type( tobj );
      
      sprintf( s, "%p [%s]", tobj, type );
      
      return gc_make_pair( string_to_bstring( s ), BNIL );
   } else {
      char s[ 100 ];
      sprintf( s, "%p (offset: %p)", base, offset );
      return gc_make_pair( string_to_bstring( s ), BNIL );
   }
}

/*---------------------------------------------------------------------*/
/*    static obj_t                                                     */
/*    make_link_chain ...                                              */
/*    -------------------------------------------------------------    */
/*    Scan the entire link chain and make a Bigloo list of it.         */
/*---------------------------------------------------------------------*/
static obj_t
make_link_chain( void *current, int verbose ) {
   void *base;
   size_t offset;
   GC_ref_kind source;

   source = GC_get_back_ptr_info( current, &base, &offset );
   
   switch( source ) {
      case GC_UNREFERENCED:
	 return make_stop_chain( "<???>" );
	 
      case GC_NO_SPACE:
	 return make_stop_chain( "<Undebugged>" );
	    
      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
	 return make_root_chain( current, base, offset );
	 
      case GC_FINALIZER_REFD:
	 return make_stop_chain( "<Finalizer>" );
	 
      case GC_REFD_FROM_HEAP: {
	 return gc_make_pair(
	    make_bstring_info( current, base, offset, verbose ),
	    make_link_chain( GC_base( base ), verbose ) );
      }
   }
}

/*---------------------------------------------------------------------*/
/*    static char *                                                    */
/*    find_root_base ...                                               */
/*    -------------------------------------------------------------    */
/*    Find the address of the root holding a value.                    */
/*---------------------------------------------------------------------*/
static char *
find_root_base( void *current ) {
   void *base;
   size_t offset;
   GC_ref_kind source;

   source = GC_get_back_ptr_info( current, &base, &offset );
   
   switch( source ) {
      case GC_UNREFERENCED:
	 return "_";
	 
      case GC_NO_SPACE:
	 return "_";
	    
      case GC_REFD_FROM_ROOT:
	 sprintf( root_base_buf, "0x%x", base );
	 return root_base_buf;
	 
      case GC_REFD_FROM_REG:
	 return "reg";
	 
      case GC_FINALIZER_REFD:
	 return "_";
	 
      case GC_REFD_FROM_HEAP: {
	 return find_root_base( GC_base( base ) );
      }
   }
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_gc_explore_internal ...                                      */
/*---------------------------------------------------------------------*/
static int
bdb_gc_explore_internal( int port_num, void *gc_addr, int verbose ) {
   size_t      offset = 0;
   void       *base = 0;
   GC_ref_kind kind;
   oh         *o;
   char       *type;
   hdr        *hhdr;
   obj_t       tobj;
   char       *s;

   if( gc_addr )
      kind = GC_get_back_ptr_info( (void *)gc_addr, &base, &offset );
   else
      return bdb_heap_explore_send( port_num,
				    0,          /* kind */
				    0,          /* gen  */
				    0,          /* size */
				    "",         /* fun  */
				    0,          /* age  */
				    "<???>",    /* type */
				    BNIL,       /* link */
				    gc_addr,
				    "_" );

   switch( kind ) {
      case GC_UNREFERENCED:
	 return bdb_heap_explore_send( port_num,
				       0,       /* kind */
				       0,       /* gen  */
				       0,       /* size */
				       "",      /* fun  */
				       0,       /* age  */
				       "<???>", /* type */
				       BNIL,    /* link */
				       gc_addr,
				       "_" );
	 break;
	 
      case GC_NO_SPACE:
	 return bdb_heap_explore_send( port_num,
				       1,       /* kind */
				       0,       /* gen  */
				       0,       /* size */
				       "",      /* fun  */
				       0,       /* age  */
				       "<???>", /* type */
				       BNIL,    /* link */
				       gc_addr,
				       "_" );
	 break;

      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
 	 o    = gc_addr;
	 tobj = OH_TO_OBJ( gc_addr );
	 hhdr = GC_find_header( (ptr_t)tobj );

	 if( verbose ) {
	    printf( "bdb_gc_explore(ROOT)...\n" );
	    printf( "bdb_find_type: %p\n", tobj );
	    printf( "        tbase: %p\n", GC_base( tobj ) );
	    printf( "         file: %s\n", OH_FUNCTION( o->oh_string ) );
	    printf( "         line: %d\n", o->oh_int & 0xffff );
	    printf( "         type: %s\n", hhdr->hb_obj_kind ? bdb_find_type( tobj ) : "___" );
	    fflush( stdout );
	 }

	 if( hhdr->hb_obj_kind )
	    type = bdb_find_type( tobj );
	 else
	    type = "<STRING BUFFER>";
	 
	 sprintf( root_base_buf, "0x%x", base );
	    
	 return bdb_heap_explore_send( port_num,
				       /* kind */
				       2,
				       /* gen  */
				       o->oh_int >> 16,
				       /* size */
				       o->oh_sz,
				       /* function */
				       OH_FUNCTION( o->oh_string ),
				       /* age */
				       o->oh_int & 0xffff,
				       /* type */
				       type,
				       /* link chain */
				       BNIL,
				       /* obj address */
				       tobj,
				       /* the root address */
				       ( kind == GC_REFD_FROM_REG ) ?
				       "reg" : root_base_buf );
	 break;
	 
      case GC_REFD_FROM_HEAP:
      case GC_FINALIZER_REFD:
 	 o    = gc_addr;
	 tobj = OH_TO_OBJ( gc_addr );
	 hhdr = GC_find_header( (ptr_t)tobj );

	 if( verbose ) {
	    printf( "bdb_gc_explore(HEAP)...\n" );
	    printf( "          obj: %p\n", tobj );
	    printf( "        tbase: %p\n", GC_base( tobj ) );
	    printf( "         file: %s\n", OH_FUNCTION( o->oh_string ) );
	    printf( "         line: %d\n", o->oh_int & 0xffff );
	    printf( "          hdr: %p\n", hhdr );
	    printf( "         free: %d\n", hhdr->hb_obj_kind );
	    printf( "         type: %s\n", hhdr->hb_obj_kind ? bdb_find_type( tobj ) : "___" );
	    fflush( stdout );
	 }

	 if( hhdr->hb_obj_kind )
	    type = bdb_find_type( tobj );
	 else {
	    if( 0 && !strcmp( o->oh_string, STRING_ALLOC_FILE ) )
	       type = bdb_find_type( tobj );
	    else
	       type = "<STRING BUFFER>";
	 }

	 return bdb_heap_explore_send( port_num,
				       /* kind */
				       2,
				       /* gen  */
				       o->oh_int >> 16,
				       /* size */
				       o->oh_sz,
				       /* file */
				       OH_FUNCTION( o->oh_string ),
				       /* lnum */
				       o->oh_int & 0xffff,
				       /* type */
				       type,
				       /* link chain */ 
				       make_link_chain( GC_base( base ),
							verbose ),
				       /* obj address */
				       tobj,
				       find_root_base( GC_base( base ) ) );
	 break;
   }
}


/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_gc_explore ...                                               */
/*---------------------------------------------------------------------*/
int
bdb_gc_explore( int port_num, obj_t obj, int verbose ) {
   void *gc_addr = (void *)(((unsigned long) obj) & (~TAG_MASK));

   return bdb_gc_explore_internal( port_num, GC_base( gc_addr ), verbose );
}
   
/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_gc_explore_offset ...                                        */
/*---------------------------------------------------------------------*/
int
bdb_gc_explore_offset( int port_num, long heap_offset, int verbose ) {
   void *gc_addr = GC_get_offset_addr( heap_offset );

   return bdb_gc_explore( port_num, gc_addr, verbose );
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    GC_print_sect ...                                                */
/*---------------------------------------------------------------------*/
void
GC_print_sect() {
   int i;

   printf( "======= GC_print_sect ========================\n" );
   printf( "smallest : %p\n", GC_least_plausible_heap_addr );

   for( i = 0; i < GC_n_heap_sects; i++ ) {
      printf( "i: %d  size: %d (%dMg)  addr: %p  last addr: %p\n",
	      i,
	      GC_heap_sects[ i ].hs_bytes,
	      GC_heap_sects[ i ].hs_bytes / (1024 * 1024),
	      GC_heap_sects[ i ].hs_start,
	      (long)(GC_heap_sects[ i ].hs_start)
	      + GC_heap_sects[ i ].hs_bytes );
   }
}

/*---------------------------------------------------------------------*/
/*    static void                                                      */
/*    heap_count_types ...                                             */
/*    -------------------------------------------------------------    */
/*    This function operates a heap traversal in order to count        */
/*    how many time each object type is used. To count the type,       */
/*    we use the C number that is associated to each type.             */
/*---------------------------------------------------------------------*/
static void
heap_count_types( int hide_bdb ) {
   long heap_offset = 0;
   int line = 0, col = 0;
   long heap_size = GC_get_heap_size();
   long leak_size = 0;

   /* before scanning, we reset our counters */
   reset_live_counters();

   /* we scan the whole heap */
   while( heap_offset < heap_size ) {
      void *gc_addr = GC_get_offset_addr( heap_offset );

      if( !gc_addr || !GC_is_marked( gc_addr ) ) {
	 heap_offset += ALIGNMENT_VALUE;
      } else {
	 object_count_type( gc_addr, hide_bdb );
	 heap_offset += GC_size( gc_addr );
      }
   }

   /* we still have to sort the types because only the */
   /* (max_type_colors-1) are allocate a color. The    */
   /* other ones fall into the Misc kind.              */
   sort_type_counters();
}

/*---------------------------------------------------------------------*/
/*    char *                                                           */
/*    make_type_name ...                                               */
/*---------------------------------------------------------------------*/
char *
make_type_name( char *s ) {
   /* This is the first, we see that type, we allocate it */
   /* a new string (for its name) that we store inside    */
   /* a global BDB type name table.                       */
   int i;
   int l = strlen( s );
   char *ns = malloc( 1 + PERCENT_LEN + l );
		  
   strcpy( ns, s );
   for( i = l; i < (PERCENT_LEN + l); i++ )
      ns[ i ] = ' ';
   ns[ i ] = 0;

   return ns;
}


/*---------------------------------------------------------------------*/
/*    static void                                                      */
/*    object_count_type ...                                            */
/*    -------------------------------------------------------------    */
/*    For one object in the heap, find its Bigloo type and increment   */
/*    a counter for that type.                                         */
/*---------------------------------------------------------------------*/
static void
object_count_type( void *addr, int hide_bdb ) {
   size_t      offset = 0;
   void       *base = 0;
   void       *gc_addr;
   GC_ref_kind kind;
   void       *heap_offset = (void *)((unsigned long)addr & (~TAG_MASK));

   gc_addr = GC_base( addr );
   kind = GC_get_back_ptr_info( gc_addr, &base, &offset );

   switch( kind ) {
      case GC_UNREFERENCED:
      case GC_NO_SPACE:
	 break;

      case GC_REFD_FROM_ROOT:
      case GC_REFD_FROM_REG:
      case GC_REFD_FROM_HEAP:
      case GC_FINALIZER_REFD: {
	 int type;
	 obj_t tobj = OH_TO_OBJ( gc_addr );
	 hdr *hhdr = GC_find_header( (ptr_t)tobj );
	 oh *o = gc_addr;
	 char *s = (char *)o->oh_string;

	 if( !hide_bdb ||
	     (SYMBOLP( s ) && strncmp( OH_FUNCTION(s), BDB_PREFIX, 4 )) ) {
	    
	    if( hhdr->hb_obj_kind ) {
	       type = TYPE( tobj );
	       
	       if( type >= MAX_CLIENT_TYPES ) {
		  fprintf( stderr,
			   "Too many types, ignoring some [%d]\n",
			   type );
	       } else {
		  /* This is a regular Bigloo object, */
		  type_counters[ type ]++;
		  type_sizes[ type ] += GC_size( gc_addr );
		  if( !type_names[ type ] ) {
		     type_names[ type ] =
			make_type_name( bdb_find_type( tobj ) );
		  }
	       }
	    } else {
	       type = bgl_types_number() + 1;

	       type_counters[ MAX_CLIENT_TYPES ]++;
	       type_sizes[ MAX_CLIENT_TYPES ] += GC_size( gc_addr );
	       /* This is a dummy type (i.e. non Bigloo types object) */
	       if( !type_names[ MAX_CLIENT_TYPES ] ) {
		  type_names[ MAX_CLIENT_TYPES ] =
		     make_type_name( "STRING_BUFFER" );
	       }

	    }

	    /* object allocation hooking */
	    if( object_count_type_hook ) {
	       object_count_type_hook( gc_addr,
				       0L,
				       SYMBOLP( s ) ?
				       BSTRING_TO_STRING(SYMBOL_TO_STRING(s))
				       : OH_FUNCTION( s ),
				       type );
		  
	    }
	 }
      }
   }
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    bgl_heap_debug_mark_obj_bdb_hook ...                             */
/*    -------------------------------------------------------------    */
/*    The Bdb function to hook obj allocations.                        */
/*---------------------------------------------------------------------*/
void
bgl_heap_debug_mark_obj_bdb_hook( obj_t obj ) {
   void *gc_addr = GC_base( CREF( obj ) );
   char *s = (char *)((oh *)gc_addr)->oh_string;

   if( !locked_bdb_hook &&
       SYMBOLP( s ) &&
       strncmp( BSTRING_TO_STRING( SYMBOL_TO_STRING( s ) ), BDB_PREFIX, 4 ) ) {
      int type = TYPE( obj );
      int size = GC_size( CREF( obj ) );

      /* we mark that we are marking an allocation (avoid re-entrance) */
      bdb_set_lock();

      /* start the allocation accounting */
      aobject_number++;
      aobject_size += size;
   
      type_acounters[ type ]++;
      type_asizes[ type ] += size;

      if( !type_names[ type ] )
	 type_names[ type ] = make_type_name( bdb_find_type( obj ) );

      /* account for the allocation producer */
      bdb_allocated_producer_add( BSTRING_TO_STRING( SYMBOL_TO_STRING( s ) ),
				  type );
      
      /* release the hook lock */
      bdb_release_lock();
   }
/*    else {                                                           */
/*       if( locked_bdb_hook &&                                        */
/* 	  (SYMBOLP( s ) && strncmp( OH_FUNCTION(s), BDB_PREFIX, 4 )) ) { */
/*    else {                                                           */
/*       if( !SYMBOLP( s )                                             */
/* 	  || (SYMBOLP( s ) &&                                          */
/* 	      strncmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(s)),BDB_PREFIX,4))) { */
/*       printf( "obj_hook: unmark(locked): %d %p %s %s size: %d [%s]\n", */
/* 	      locked_bdb_hook,                                         */
/* 	      obj,                                                     */
/* 	      bdb_find_type( obj ),                                    */
/* 	      SYMBOLP( s ) ?                                           */
/* 	      BSTRING_TO_STRING( SYMBOL_TO_STRING( s ) )               */
/* 	      : (((obj_t)s == BUNSPEC) ? "BUNSPEC" : "???"),           */
/* 	      GC_size( CREF( obj ) ),                                  */
/* 	      !strcmp( bdb_find_type( obj ), "BSTRING" ) ?             */
/* 	      BSTRING_TO_STRING( obj ) : "" );                         */
/*       }                                                             */
/*    }                                                                */
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    bgl_heap_debug_mark_str_bdb_hook ...                             */
/*    -------------------------------------------------------------    */
/*    The Bdb function to hook string buffer allocations.              */
/*---------------------------------------------------------------------*/
void bgl_heap_debug_mark_str_bdb_hook( char *buf ) {
   void *gc_addr = GC_base( buf );
   char *s = (char *)((oh *)gc_addr)->oh_string;

   if( !locked_bdb_hook &&
       SYMBOLP( s ) &&
       strncmp( BSTRING_TO_STRING( SYMBOL_TO_STRING( s ) ), BDB_PREFIX, 4 ) ) {
      int size = GC_size( buf );

      /* we mark that we are marking an allocation (avoid re-entrance) */
      bdb_set_lock();
      
      /* start the allocation accounting */
      aobject_number++;
      aobject_size += size;
   
      type_acounters[ MAX_CLIENT_TYPES ]++;
      type_asizes[ MAX_CLIENT_TYPES ] += size;
   
      if( !type_names[ MAX_CLIENT_TYPES ] )
	 type_names[ MAX_CLIENT_TYPES ] = make_type_name( "STRING_BUFFER" );

      /* account for the allocation producer */
      bdb_allocated_producer_add( BSTRING_TO_STRING( SYMBOL_TO_STRING( s ) ),
				  bgl_types_number() + 1 );

      /* release the hook lock */
      bdb_release_lock();
   }
/*    else {                                                           */
/*       if( !SYMBOLP( s )                                             */
/* 	  || (SYMBOLP( s ) &&                                          */
/* 	      strncmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(s)),BDB_PREFIX,4))) { */
/* 	 printf( "str_hook: Je ne marque pas: %d %p %s size: %d\n",    */
/* 	      locked_bdb_hook, buf,                                    */
/* 	      SYMBOLP( s ) ? BSTRING_TO_STRING( SYMBOL_TO_STRING( s ) ) : "???", */
/* 	      GC_size( buf ) );                                        */
/*       }                                                             */
/*    }                                                                */
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    bdb_init_allocation_hooks ...                                    */
/*    -------------------------------------------------------------    */
/*    The initialisation of the GC_profile hooking routines.           */
/*---------------------------------------------------------------------*/
int
bdb_init_allocation_hooks() {
   /* we set the hooking routines */
   bgl_heap_debug_mark_hooks_set( bgl_heap_debug_mark_obj_bdb_hook,
				  bgl_heap_debug_mark_str_bdb_hook );

   /* we prepare the local allocation counting */
   reset_alloc_counters();
   
   return 1;
}

/*---------------------------------------------------------------------*/
/*    static void                                                      */
/*    reset_live_counters ...                                          */
/*    -------------------------------------------------------------    */
/*    We reset the BDB type counters. In this function, we do not      */
/*    clean the type name table because Bigloo types key are unique    */
/*    and during a execution only one type is associated to one        */
/*    key.                                                             */
/*---------------------------------------------------------------------*/
static void
reset_live_counters() {
   int i;

   for( i = 0; i < MAX_BDB_TYPES; i++ ) {
      type_counters[ i ] = 0;
      type_sizes[ i ] = 0;
      type_colors[ i ] = MISC_TYPE_CHAR;
      color_to_type[ i ] = -1;
   }
}

/*---------------------------------------------------------------------*/
/*    static void                                                      */
/*    reset_alloc_counters ...                                         */
/*    -------------------------------------------------------------    */
/*    We reset the BDB type counters. In this function, we do not      */
/*    clean the type name table because Bigloo types key are unique    */
/*    and during a execution only one type is associated to one        */
/*    key.                                                             */
/*---------------------------------------------------------------------*/
static void
reset_alloc_counters() {
   int i;

   /* and we prepare the allocation tables */
   bdb_allocated_producer_reset();
   
   for( i = 0; i < MAX_BDB_TYPES; i++ ) {
      type_acounters[ i ] = 0;
      type_asizes[ i ] = 0;
   }
   
   aobject_number = 0;
   aobject_size = 0;
}

/*---------------------------------------------------------------------*/
/*    A local structure that is only used to sort the counters.        */
/*---------------------------------------------------------------------*/
struct col_info {
   long type, count, size;
   struct col_info *inf, *sup;
};

/*---------------------------------------------------------------------*/
/*    static struct col_info *                                         */
/*    insert ...                                                       */
/*---------------------------------------------------------------------*/
static struct col_info *
insert_types( struct col_info *tree, struct col_info *new ) {
   if( !tree )
      return new;
   else {
      if( new->count > tree->count ) 
	 tree->sup = insert_types( tree->sup, new );
      else
	 tree->inf = insert_types( tree->inf, new );
      return tree;
   }
}

/*---------------------------------------------------------------------*/
/*    static int                                                       */
/*    set_type_colors ...                                              */
/*---------------------------------------------------------------------*/
static int
set_type_colors( struct col_info *head, int ranking ) {
   if( !head )
      return ranking;
   else {
      int new_ranking;

      /* first, we traverse the more frequently used types */
      new_ranking = set_type_colors( head->sup, ranking );
      
      if( new_ranking >= (max_type_colors - 1) )
	 return new_ranking;
      else {
	 int type = head->type;
	 
	 /* we substract the number current number to the remaiming types */
	 other_number -= type_counters[ type ];
	 other_size -= type_sizes[ type ];
	 
	 type_colors[ type ] = char_colors[ new_ranking ];
	 
	 /* the color_to_type vector is used to compute the legend    */
	 /* of the picture, that is, at some point we will be needing */
	 /* for each allocated color the associated type.             */
	 color_to_type[ new_ranking ] = type;

	 return set_type_colors( head->inf, new_ranking + 1 );
      }
   }
}

/*---------------------------------------------------------------------*/
/*    static void                                                      */
/*    sort_type_counters ...                                           */
/*    -------------------------------------------------------------    */
/*    We sort the types by their number of use. In addition, we        */
/*    compute here some more metrics. We compute the relative          */
/*    percentage of type use.                                          */
/*---------------------------------------------------------------------*/
static void
sort_type_counters() {
   int i;
   struct col_info *head = 0;
   struct col_info ci[ MAX_BDB_TYPES ];
   object_number = 0;
   object_size = 0;
   
   /* we sort the types */
   for( i = 0; i < MAX_BDB_TYPES; i++ ) {
      if( type_counters[ i ] || type_acounters[ i ] ) {
	 /* we add an entry for a type if there is a live occurrence */
	 /* or if previous occurrences have already been allocated.  */
	 ci[ i ].type = i;
	 ci[ i ].count = type_counters[ i ];
	 ci[ i ].size = type_sizes[ i ];
	 ci[ i ].inf = 0L;
	 ci[ i ].sup = 0L;

	 object_number += type_counters[ i ];
	 object_size += type_sizes[ i ];
	 
	 head = insert_types( head, &ci[ i ] );
      }
   }

   /* we prepare the other number computation (see set_type_colors) */
   other_number = object_number;
   other_size = object_size;

   /* the most frequently used are allocated another color */
   set_type_colors( head, 1 );
}

