/*=====================================================================*/
/*    serrano/prgm/project/bigloo/bde/bmem/lib/alloc.c                 */
/*    -------------------------------------------------------------    */
/*    Author      :  Manuel Serrano                                    */
/*    Creation    :  Sun Apr 13 06:42:57 2003                          */
/*    Last change :  Wed Aug 13 13:57:57 2003 (serrano)                */
/*    Copyright   :  2003 Manuel Serrano                               */
/*    -------------------------------------------------------------    */
/*    Allocation replacement routines                                  */
/*=====================================================================*/
#define THE_GC NO_GC
#include <bigloo.h>
#include <bmem.h>
#include <esymbol.h>
#include <stdlib.h>

/*---------------------------------------------------------------------*/
/*    static pa_pair_t *                                               */
/*    all_functions ...                                                */
/*---------------------------------------------------------------------*/
static pa_pair_t *all_functions = 0;
static int stamp = 1;
static int alloc_type = -1;
static long max_stack_size = 100000;
unsigned long ante_bgl_init_dsz = 0;

/*---------------------------------------------------------------------*/
/*    char *                                                           */
/*    all_types ...                                                    */
/*---------------------------------------------------------------------*/
static char **all_types = 0;
static int types_number = 0;

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    set_alloc_type ...                                               */
/*---------------------------------------------------------------------*/
void
set_alloc_type( int t ) {
   if( bmem_thread ) {
      ____bglthread_setspecific( bmem_key, (void *)t );
   } else {
      alloc_type = t;
   }
}

/*---------------------------------------------------------------------*/
/*    int                                                              */
/*    get_alloc_type ...                                               */
/*---------------------------------------------------------------------*/
int
get_alloc_type() {
   if( bmem_thread ) {
      return (int)____bglthread_getspecific( bmem_key );
   } else {
      return alloc_type;
   }
}
    
/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    type_dump ...                                                    */
/*---------------------------------------------------------------------*/
void
type_dump( FILE *f ) {
   int i;
   
   fprintf( f, "  (type" );
   for( i = 0; i < types_number; i++ ) {
      if( all_types[ i ] )
         fprintf( f, "\n    (%d \"%s\")", i, all_types[ i ] );
   }
   fprintf( f, ")\n" );
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    declare_type ...                                                 */
/*---------------------------------------------------------------------*/
void
declare_type( int tnum, char *tname ) {
   if( (tnum + 1) > types_number ) {
      all_types = (char **)realloc( all_types, (tnum + 1) * sizeof(char *)  );
      memset( &all_types[ types_number ],
              0,
              (tnum-types_number) * sizeof(char *) );
      types_number = tnum + 1;
   }

   all_types[ tnum ] = tname;
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    alloc_dump_type ...                                              */
/*---------------------------------------------------------------------*/
void
alloc_dump_type( pa_pair_t *i, FILE *f ) {
   type_alloc_info_t *tai = (type_alloc_info_t *)PA_CDR( i );
   
   fprintf( f, "\n          (%d %d %d)", (long)PA_CAR( i ),
	    tai->num, BMEMSIZE( tai->size ) );
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    alloc_dump ...                                                   */
/*---------------------------------------------------------------------*/
void
alloc_dump( fun_alloc_info_t *i, FILE *f ) {
   fprintf( f, "      (%d %d %d\n", i->gc_num,
	    BMEMSIZE( i->dsize ), BMEMSIZE( i->isize ) );
   fprintf( f, "        (dtype" );
   for_each( (void (*)(void *, void *))alloc_dump_type, i->dtypes, f );
   fprintf( f, ")\n" );
   fprintf( f, "        (itype" );
   for_each( (void (*)(void *, void *))alloc_dump_type, i->itypes, f );
   fprintf( f, "))\n" );
}
   
/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    fun_dump ...                                                     */
/*---------------------------------------------------------------------*/
void
fun_dump( void *ident, FILE *f ) {
   esymbol_t *fun = (esymbol_t *)ident;
   
   fprintf( f, "\n    (%s\n", BSTRING_TO_STRING( SYMBOL_TO_STRING( fun ) ) );
   for_each( (void (*)(void *, void *))alloc_dump, fun->alloc_info, f );
   fprintf( f, "      )" );
}
   
/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    alloc_dump_statistics ...                                        */
/*---------------------------------------------------------------------*/
void
alloc_dump_statistics( FILE *f ) {
   fprintf( f, "  (function" );
   for_each( (void (*)(void *, void *))fun_dump, all_functions, (void *)f );
   fprintf( f, ")\n" );
}

/*---------------------------------------------------------------------*/
/*    fun_alloc_info_t *                                               */
/*    make_fun_alloc_info ...                                          */
/*---------------------------------------------------------------------*/
fun_alloc_info_t *
make_fun_alloc_info( long gc, long dsz, long isz ) {
   fun_alloc_info_t *i = malloc( sizeof( struct fun_alloc_info ) );

   if( !i ) FAIL( IDENT, "Can't alloc fun_alloc_info", 0 );
   
   i->gc_num = gc;
   
   i->dsize = dsz;
   i->isize = isz;
   
   i->dtypes = 0;
   i->itypes = 0;

   return i;
}
  
/*---------------------------------------------------------------------*/
/*    type_alloc_info_t *                                              */
/*    make_type_alloc_info ...                                         */
/*---------------------------------------------------------------------*/
type_alloc_info_t *
make_type_alloc_info() {
   type_alloc_info_t *new = calloc( sizeof( struct type_alloc_info ), 1 );
   return new;
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    mark_type ...                                                    */
/*---------------------------------------------------------------------*/
void
mark_type( fun_alloc_info_t *i, int dtype, long dsize, int itype, long isize ) {
   if( dtype >=  0 ) {
      pa_pair_t *cell = pa_assq( (void *)dtype, (pa_pair_t *)(i->dtypes) );

      if( cell ) {
	 type_alloc_info_t *tai = (type_alloc_info_t *)PA_CDR( cell );
	 tai->num += 1;
	 tai->size += dsize;
      } else {
	 type_alloc_info_t *new = make_type_alloc_info();
	 new->num = 1;
	 new->size = dsize;
	 i->dtypes = pa_cons( pa_cons( (void *)dtype, (void *)new ),
			      (pa_pair_t *)(i->dtypes) );
      }
   }
   
   if( itype >=  0 ) {
      pa_pair_t *cell = pa_assq( (void *)itype, (pa_pair_t *)(i->itypes) );

      if( cell ) {
	 type_alloc_info_t *tai = (type_alloc_info_t *)PA_CDR( cell );
	 tai->num += 1;
	 tai->size += isize;
      } else {
	 type_alloc_info_t *new = make_type_alloc_info();
	 new->num = 1;
	 new->size = isize;
	 i->itypes = pa_cons( pa_cons( (void *)itype, (void *)new ),
			      (pa_pair_t *)(i->itypes) );
      }
   }
}
      
      
/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    mark_function ...                                                */
/*---------------------------------------------------------------------*/
void
mark_function( void *id, long gc, long dsz, long isz, int dt, int it, long stamp ) {
   esymbol_t *fun;
   
   if( !SYMBOLP( id ) ) {
      if( unknown_ident )
	 mark_function( unknown_ident, gc, dsz, isz, dt, it, stamp );
      else {
	 if( !gc ) {
	    ante_bgl_init_dsz += dsz;
	 } else
	    fprintf( stderr,
		     "*** WARNING: giving up with some allocations: %d\n",
		     dsz );
      }
      return;
   }
   
   fun = (esymbol_t *)CREF( id );

   if( !dsz && (fun->stamp == stamp) ) {
      return;
   } else {
      fun->stamp = stamp;
   }
   
   if( !fun->alloc_info ) {
      fun_alloc_info_t *nfai = make_fun_alloc_info( gc, dsz, isz );

      mark_type( nfai, dt, dsz, it, isz );
      all_functions = pa_cons( id, all_functions );
      fun->alloc_info = pa_cons( nfai, 0 );
   } else {
      fun_alloc_info_t *ofai = ((fun_alloc_info_t *)(PA_CAR( ((pa_pair_t *)fun->alloc_info) )));
      
      if( ofai->gc_num != gc ) {
	 fun_alloc_info_t *nfai = make_fun_alloc_info( gc, dsz, isz );
	 
	 mark_type( nfai, dt, dsz, it, isz );
	 fun->alloc_info = pa_cons( nfai, fun->alloc_info );
      } else {

	 mark_type( ofai, dt, dsz, it, isz );

	 ofai->dsize += dsz;
	 ofai->isize += isz;
      }
   }
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    mark_rest_functions ...                                          */
/*---------------------------------------------------------------------*/
void
mark_rest_functions( void *id, void *isize ) {
   mark_function( id, gc_number, 0, (int)isize, -1, get_alloc_type(), stamp );
}

/*---------------------------------------------------------------------*/
/*    void *                                                           */
/*    make_pair ...                                                    */
/*---------------------------------------------------------------------*/
void *
make_pair( void *car, void *cdr ) {
   set_alloc_type( PAIR_TYPE_NUM );

   if( !bmem_thread ) {
      gc_alloc_size += PAIR_SIZE;

      mark_function( bgl_debug_trace_top(),
		     gc_number,
		     PAIR_SIZE, 0,
		     get_alloc_type(), -1,
		     ++stamp );
      for_each_trace( mark_rest_functions, 1, max_stack_size, (void *)PAIR_SIZE );
      set_alloc_type( -1 );
   }
   
   return ____make_pair( car, cdr );
}

/*---------------------------------------------------------------------*/
/*    void *                                                           */
/*    make_cell ...                                                    */
/*---------------------------------------------------------------------*/
void *
make_cell( void *val ) {
   set_alloc_type( CELL_TYPE_NUM );

   if( !bmem_thread ) {
      gc_alloc_size += CELL_SIZE;

      mark_function( bgl_debug_trace_top(),
		     gc_number,
		     CELL_SIZE, 0,
		     get_alloc_type(), -1,
		     ++stamp );
      for_each_trace( mark_rest_functions, 1, max_stack_size, (void *)CELL_SIZE );
      set_alloc_type( -1 );
   }
   
   return ____make_cell( val );
}

/*---------------------------------------------------------------------*/
/*    void *                                                           */
/*    make_real ...                                                    */
/*---------------------------------------------------------------------*/
void *
make_real( double d ) {
   set_alloc_type( REAL_TYPE_NUM );

   if( !bmem_thread ) {
      gc_alloc_size += REAL_SIZE;

      mark_function( bgl_debug_trace_top(),
		     gc_number,
		     REAL_SIZE, 0,
		     get_alloc_type(), -1,
		     ++stamp );
      for_each_trace( mark_rest_functions, 1, max_stack_size, (void *)REAL_SIZE );
      set_alloc_type( -1 );
   }
   
   return ____make_real( d );
}

/*---------------------------------------------------------------------*/
/*    static void                                                      */
/*    GC_malloc_find_type ...                                          */
/*---------------------------------------------------------------------*/
static void
GC_malloc_find_type( int lb ) {
   void *top = bgl_debug_trace_top();

   if( SYMBOLP( top ) ) {
      set_alloc_type( ((esymbol_t *)CREF( top ))->class_alloc );
#if BMEMDEBUG
      if( bmem_debug >= 10 ) {
	 fprintf( stderr, "UNKNOWN_TYPE_NUM(debug=10) GC_malloc(%d): %s %d\n",
		  lb, bgl_debug_trace_top_name(), get_alloc_type() );
      }
#endif
   } else {
      set_alloc_type( UNKNOWN_TYPE_NUM );
      if( bmem_debug >= 10 ) {
	 fprintf( stderr, "UNKNOWN_TYPE_NUM(debug=10) GC_malloc(%d): ???? %d\n",
		  lb, get_alloc_type() );
      }
   }
}

/*---------------------------------------------------------------------*/
/*    void *                                                           */
/*    GC_malloc ...                                                    */
/*---------------------------------------------------------------------*/
void *
GC_malloc( size_t lb ) {
   gc_alloc_size += lb;
   
   if( get_alloc_type() == -1 )
      GC_malloc_find_type( lb );

#if BMEMDEBUG
   if( bmem_debug ) {
      fprintf( stderr, "GC_malloc(%d): %s %d\n",
	       lb, bgl_debug_trace_top_name(), get_alloc_type() );
   }
#endif
      
   mark_function( bgl_debug_trace_top(),
		  gc_number,
		  lb, 0,
		  get_alloc_type(), -1,
		  ++stamp );
   for_each_trace( mark_rest_functions, 1, max_stack_size, (void *)lb );
   set_alloc_type( -1 );
   
   return ____GC_malloc( lb );
}

/*---------------------------------------------------------------------*/
/*    void *                                                           */
/*    GC_malloc_atomic ...                                             */
/*---------------------------------------------------------------------*/
void *
GC_malloc_atomic( size_t lb ) {
   gc_alloc_size += lb;

   if( get_alloc_type() == -1 )
      GC_malloc_find_type( lb );

#if BMEMDEBUG
   if( bmem_debug ) {
      fprintf( stderr, "GC_malloc_atomic(%d): %s %d\n",
	       lb, bgl_debug_trace_top_name(), get_alloc_type() );
   }
#endif
      
   mark_function( bgl_debug_trace_top(),
		  gc_number,
		  lb, 0,
		  get_alloc_type(), -1,
		  ++stamp );
   for_each_trace( mark_rest_functions, 1, max_stack_size, (void *)lb );
   set_alloc_type( -1 );
   
   return ____GC_malloc_atomic( lb );
}

/*---------------------------------------------------------------------*/
/*    void *                                                           */
/*    GC_local_malloc ...                                              */
/*    -------------------------------------------------------------    */
/*    We have to disable the GC_local_malloc function otherwise        */
/*    we get confused in function such as make_pair in                 */
/*    multithreaded environment.                                       */
/*---------------------------------------------------------------------*/
void *
GC_local_malloc( size_t lb ) {
   return GC_malloc( lb );
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    register_class ...                                               */
/*---------------------------------------------------------------------*/
obj_t
BGl_registerzd2classz12zc0zz__objectz00( obj_t name, obj_t super,
					 obj_t creator, obj_t allocate,
					 long hash, obj_t def,
					 obj_t constructor, obj_t virt ) {
   static int init = 0;
   char tmp[ 256 ];
   obj_t alloc;
   char *cname = BSTRING_TO_STRING( SYMBOL_TO_STRING( name ) );
   int tnum = ____bgl_types_number();
   obj_t class;

   if( !init ) {
      fprintf( stderr, "Defining classes...\n" );
      init = 1;
   }

   fprintf( stderr, "  %s (%d)...", cname, tnum );
   fflush( stderr );
   declare_type( tnum, cname );

   sprintf( tmp, "make-%s", cname );
   alloc = string_to_symbol( tmp );
   ((esymbol_t *)(CREF(alloc)))->class_alloc = tnum;

   sprintf( tmp, "allocate-%s", cname );
   alloc = string_to_symbol( tmp );
   ((esymbol_t *)(CREF(alloc)))->class_alloc = tnum;

   sprintf( tmp, "widening-%s", cname );
   alloc = string_to_symbol( tmp );
   ((esymbol_t *)(CREF(alloc)))->class_alloc = tnum;

   class = ____register_class( name, super, creator, allocate, hash, def,
			       constructor, virt );

   fprintf( stderr, "ok\n", cname );
   return class;
}

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    bgl_init_dynamic_env ...                                         */
/*---------------------------------------------------------------------*/
void
bgl_init_dynamic_env() {
   set_alloc_type( _DYNAMIC_ENV_TYPE_NUM );
   return ____bgl_init_dynamic_env();
}
   
/*---------------------------------------------------------------------*/
/*    WRAPPER ...                                                      */
/*---------------------------------------------------------------------*/
#define WRAPPER( ident, tnum, proto, call ) \
obj_t ident proto { \
   set_alloc_type( tnum ); \
   return ____##ident call ; \
}

/*---------------------------------------------------------------------*/
/*    WRAPPER2 ...                                                     */
/*---------------------------------------------------------------------*/
#define WRAPPER2( ident, tnum1, tnum2, proto, call ) \
obj_t ident proto { \
   obj_t aux; \
   set_alloc_type( tnum1 ); \
   aux = ____##ident call ; \
   set_alloc_type( tnum2 ); \
   return aux; \
}

/*---------------------------------------------------------------------*/
/*    WRAPPER3 ...                                                     */
/*---------------------------------------------------------------------*/
#define WRAPPER3( type, ident, tnum, proto, call ) \
type ident proto { \
   set_alloc_type( tnum ); \
   return ____##ident call ; \
}

/*---------------------------------------------------------------------*/
/*    WRAPPER4 ...                                                     */
/*---------------------------------------------------------------------*/
#define bgl_current_dynamic_env \
   ((bgldenv_t)(____bgl_get_current_dynamic_env())) 

#define WRAPPER4( ident, var, sym, proto, call ) \
obj_t ident proto { \
   static obj_t s = 0; \
   if( !s ) s = string_to_symbol( sym ); \
   { \
     obj_t res; \
     PUSH_TRACE( s ); \
     res = var call ; \
     POP_TRACE(); \
     return res; \
   } \
}
 
/* string */
WRAPPER( string_to_bstring_len, STRING_TYPE_NUM, (char *s, int l), (s ,l) )
WRAPPER( make_string, STRING_TYPE_NUM, (int l, char c), (l,c)  )
WRAPPER( make_string_sans_fill, STRING_TYPE_NUM, (int l), (l) )
WRAPPER( string_append, STRING_TYPE_NUM, (void *s1, void *s2), (s1, s2) )
WRAPPER( string_append_3, STRING_TYPE_NUM, (void *s1, void *s2, void *s3), (s1, s2, s3) )
WRAPPER( c_substring, STRING_TYPE_NUM, (void *s, int l1, int l2), (s, l1, l2) )
WRAPPER( escape_C_string, STRING_TYPE_NUM, (char *s), (s) )
WRAPPER( escape_scheme_string, STRING_TYPE_NUM, (char *s), (s) )

/* vector */
WRAPPER( create_vector, VECTOR_TYPE_NUM, (int len), (len) )
WRAPPER( make_vector, VECTOR_TYPE_NUM, (int len, void *init), (len, init) )

/* procedure */
WRAPPER( make_fx_procedure, PROCEDURE_TYPE_NUM, (obj_t (*e)(), int a, int s), ((void *(*)())e, a, s) )
WRAPPER( make_va_procedure, PROCEDURE_TYPE_NUM, (obj_t (*e)(), int a, int s), ((void *(*)())e, a, s) )

/* output port */
WRAPPER( make_output_port, OUTPUT_PORT_TYPE_NUM, (char *s, FILE *f, obj_t o), (s, f, o) )
WRAPPER( open_output_file, OUTPUT_PORT_TYPE_NUM, (void *o), (o) )
WRAPPER( append_output_file, OUTPUT_PORT_TYPE_NUM, (void *o), (o) )
WRAPPER( open_output_string, OUTPUT_PORT_TYPE_NUM, (void *o), (o) )
WRAPPER( strport_grow, ROWSTRING_TYPE_NUM, (void *o), (o) )

/* input port */
WRAPPER2( make_input_port, INPUT_PORT_TYPE_NUM, ROWSTRING_TYPE_NUM, (char *s, FILE *f, void *o, long l), (s, f, o, l) )
WRAPPER2( open_input_file, INPUT_PORT_TYPE_NUM, ROWSTRING_TYPE_NUM, (void *o1, void *o2), (o1, o2) )
WRAPPER( open_input_console, INPUT_PORT_TYPE_NUM, (), () )
WRAPPER( file_to_buffered_input_port, INPUT_PORT_TYPE_NUM, (FILE *f, long l), (f, l) )
WRAPPER( file_to_input_port, INPUT_PORT_TYPE_NUM, (FILE *f), (f) )
WRAPPER( open_input_string, INPUT_PORT_TYPE_NUM, (void *o), (o) )
WRAPPER( open_input_c_string, INPUT_PORT_TYPE_NUM, (char *s), (s) )
WRAPPER( reopen_input_c_string, INPUT_PORT_TYPE_NUM, (void *o, char *s), (o, s) )

/* struct */
WRAPPER( create_struct, STRUCT_TYPE_NUM, (obj_t k, int l), (k, l) )
WRAPPER( make_struct, STRUCT_TYPE_NUM, (obj_t k, int l, obj_t i), (k, l, i) )

/* socket */ 
WRAPPER( make_client_socket, SOCKET_TYPE_NUM, (obj_t h, int p, char b), (h, p, b) )
WRAPPER( make_server_socket, SOCKET_TYPE_NUM, (int p), (p) )
WRAPPER( socket_dup, SOCKET_TYPE_NUM, (obj_t p), (p) )
WRAPPER( socket_accept, SOCKET_TYPE_NUM, (obj_t s, char b, int e), (s, b, e) )

/* dynamic environment */
WRAPPER( make_dynamic_env, _DYNAMIC_ENV_TYPE_NUM, (), () )
WRAPPER3( bgldenv_t, bgl_dup_dynamic_env, _DYNAMIC_ENV_TYPE_NUM, (bgldenv_t o), (o) )

/* thread */
WRAPPER( bglthread_new, _THREAD_TYPE_NUM, (obj_t p), (p) )
WRAPPER( bglthread_new_with_name, _THREAD_TYPE_NUM, (obj_t p, obj_t n), (p,n) )
WRAPPER4( BGl_schedulerzd2startz12zc0zz__ft_schedulerz00, ____scheduler_start, "scheduler-start!", (obj_t o), (o) )
WRAPPER4( BGl_schedulerzd2reactz12zc0zz__ft_schedulerz00, ____scheduler_react, "scheduler-react!", (obj_t o), (o) )
