/* malloc.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

   Related Modules:
      None

   Description:
      Fast pool-based memory allocation.

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "malloc.h"

/* Externals defined here.  */

struct _malloc_root_ malloc_root_
=
{
  {
    &malloc_root_.malloc_pool_image_,
    &malloc_root_.malloc_pool_image_,
    (mallocPool) &malloc_root_.malloc_pool_image_.eldest,
    (mallocPool) &malloc_root_.malloc_pool_image_.eldest,
    (mallocArea_) &malloc_root_.malloc_pool_image_.first,
    (mallocArea_) &malloc_root_.malloc_pool_image_.first,
    0,
#if MALLOC_DEBUG
    0, 0, 0, 0, 0, 0, 0, { '/' }
#else
    { 0 }
#endif
  },
};

/* Simple definitions and enumerations. */


/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


/* Static objects accessed by functions in this module. */

static void *malloc_reserve_ = NULL;	/* For crashes. */
#if MALLOC_DEBUG
static const char *malloc_types_[] =
{"KS", "KSR", "NF", "NFR", "US", "USR"};
#endif

/* Static functions (internal). */

static void malloc_kill_area_ (mallocPool pool, mallocArea_ a);
#if MALLOC_DEBUG
static void malloc_verify_area_ (mallocPool pool, mallocArea_ a);
#endif

/* Internal macros. */

#if MALLOC_DEBUG
#define malloc_kill_(ptr,s) do {memset((ptr),127,(s));free((ptr));} while(0)
#else
#define malloc_kill_(ptr,s) free((ptr))
#endif

/* malloc_kill_area_ -- Kill storage area and its object

   malloc_kill_area_(mallocPool pool,mallocArea_ area);

   Does the actual killing of a storage area.  */

static void
malloc_kill_area_ (mallocPool pool UNUSED, mallocArea_ a)
{
#if MALLOC_DEBUG
  assert (strcmp (a->name, ((char *) (a->where)) + a->size) == 0);
#endif
  malloc_kill_ (a->where, a->size);
  a->next->previous = a->previous;
  a->previous->next = a->next;
#if MALLOC_DEBUG
  pool->freed += a->size;
  pool->frees++;
#endif
  malloc_kill_ (a,
		offsetof (struct _malloc_area_, name)
		+ strlen (a->name) + 1);
}

/* malloc_verify_area_ -- Verify storage area and its object

   malloc_verify_area_(mallocPool pool,mallocArea_ area);

   Does the actual verifying of a storage area.  */

#if MALLOC_DEBUG
static void
malloc_verify_area_ (mallocPool pool UNUSED, mallocArea_ a UNUSED)
{
  mallocSize s = a->size;

  assert (strcmp (a->name, ((char *) (a->where)) + s) == 0);
}
#endif

/* malloc_init -- Initialize malloc cluster

   malloc_init();

   Call malloc_init before you do anything else.  */

void
malloc_init ()
{
  if (malloc_reserve_ != NULL)
    return;
  malloc_reserve_ = malloc (20 * 1024);	/* In case of crash, free this first. */
  assert (malloc_reserve_ != NULL);
}

/* malloc_pool_display -- Display a pool

   mallocPool p;
   malloc_pool_display(p);

   Displays information associated with the pool and its subpools.  */

void
malloc_pool_display (mallocPool p UNUSED)
{
#if MALLOC_DEBUG
  mallocPool q;
  mallocArea_ a;

  fprintf (dmpout, "Pool \"%s\": bytes allocated=%lu, freed=%lu, old sizes=%lu, new sizes\
=%lu,\n   allocations=%lu, frees=%lu, resizes=%lu, uses=%lu\n   Subpools:\n",
	   p->name, p->allocated, p->freed, p->old_sizes, p->new_sizes, p->allocations,
	   p->frees, p->resizes, p->uses);

  for (q = p->eldest; q != (mallocPool) & p->eldest; q = q->next)
    fprintf (dmpout, "      \"%s\"\n", q->name);

  fprintf (dmpout, "   Storage areas:\n");

  for (a = p->first; a != (mallocArea_) & p->first; a = a->next)
    {
      fprintf (dmpout, "      ");
      malloc_display_ (a);
    }
#endif
}

/* malloc_pool_kill -- Destroy a pool

   mallocPool p;
   malloc_pool_kill(p);

   Releases all storage associated with the pool and its subpools.  */

void
malloc_pool_kill (mallocPool p)
{
  mallocPool q;
  mallocArea_ a;

  if (--p->uses != 0)
    return;

#if 0
  malloc_pool_display (p);
#endif

  assert (p->next->previous == p);
  assert (p->previous->next == p);

  /* Kill off all the subpools. */

  while ((q = p->eldest) != (mallocPool) &p->eldest)
    {
      q->uses = 1;		/* Force the kill. */
      malloc_pool_kill (q);
    }

  /* Now free all the storage areas. */

  while ((a = p->first) != (mallocArea_) & p->first)
    {
      malloc_kill_area_ (p, a);
    }

  /* Now remove from list of sibling pools. */

  p->next->previous = p->previous;
  p->previous->next = p->next;

  /* Finally, free the pool itself. */

  malloc_kill_ (p,
		offsetof (struct _malloc_pool_, name)
		+ strlen (p->name) + 1);
}

/* malloc_pool_new -- Make a new pool

   mallocPool p;
   p = malloc_pool_new("My new pool",malloc_pool_image(),1024);

   Makes a new pool with the given name and default new-chunk allocation.  */

mallocPool
malloc_pool_new (const char *name, mallocPool parent,
		 unsigned long chunks UNUSED)
{
  mallocPool p;

  if (parent == NULL)
    parent = malloc_pool_image ();

  p = malloc_new_ (offsetof (struct _malloc_pool_, name)
		   + (MALLOC_DEBUG ? strlen (name) + 1 : 0));
  p->next = (mallocPool) &(parent->eldest);
  p->previous = parent->youngest;
  parent->youngest->next = p;
  parent->youngest = p;
  p->eldest = (mallocPool) &(p->eldest);
  p->youngest = (mallocPool) &(p->eldest);
  p->first = (mallocArea_) &(p->first);
  p->last = (mallocArea_) &(p->first);
  p->uses = 1;
#if MALLOC_DEBUG
  p->allocated = p->freed = p->old_sizes = p->new_sizes = p->allocations
    = p->frees = p->resizes = 0;
  strcpy (p->name, name);
#endif
  return p;
}

/* malloc_pool_use -- Use an existing pool

   mallocPool p;
   p = malloc_pool_new(pool);

   Increments use count for pool; means a matching malloc_pool_kill must
   be performed before a subsequent one will actually kill the pool.  */

mallocPool
malloc_pool_use (mallocPool pool)
{
  ++pool->uses;
  return pool;
}

/* malloc_display_ -- Display info on a mallocArea_

   mallocArea_ a;
   malloc_display_(a);

   Simple.  */

void
malloc_display_ (mallocArea_ a UNUSED)
{
#if MALLOC_DEBUG
  fprintf (dmpout, "At %08lX, size=%" mallocSize_f "u, type=%s, \"%s\"\n",
	(unsigned long) a->where, a->size, malloc_types_[a->type], a->name);
#endif
}

/* malloc_find_inpool_ -- Find mallocArea_ for object in pool

   mallocPool pool;
   void *ptr;
   mallocArea_ a;
   a = malloc_find_inpool_(pool,ptr);

   Search for object in list of mallocArea_s, die if not found.	 */

mallocArea_
malloc_find_inpool_ (mallocPool pool, void *ptr)
{
  mallocArea_ a;
  mallocArea_ b = (mallocArea_) &pool->first;
  int n = 0;

  for (a = pool->first; a != (mallocArea_) &pool->first; a = a->next)
    {
      assert (("Infinite loop detected" != NULL) && (a != b));
      if (a->where == ptr)
	return a;
      ++n;
      if (n & 1)
	b = b->next;
    }
  assert ("Couldn't find object in pool!" == NULL);
  return NULL;
}

/* malloc_kill_inpool_ -- Kill object

   malloc_kill_inpool_(NULL,MALLOC_typeUS_,ptr,size_in_bytes);

   Find the mallocArea_ for the pointer, make sure the type is proper, and
   kill both of them.  */

void
malloc_kill_inpool_ (mallocPool pool, mallocType_ type UNUSED,
		     void *ptr, mallocSize s UNUSED)
{
  mallocArea_ a;

  if (pool == NULL)
    pool = malloc_pool_image ();

#if MALLOC_DEBUG
  assert ((pool == malloc_pool_image ())
	  || malloc_pool_find_ (pool, malloc_pool_image ()));
#endif

  a = malloc_find_inpool_ (pool, ptr);
#if MALLOC_DEBUG
  assert (a->type == type);
  if ((type != MALLOC_typeUS_) && (type != MALLOC_typeUSR_))
    assert (a->size == s);
#endif
  malloc_kill_area_ (pool, a);
}

/* malloc_new_ -- Allocate new object, die if unable

   ptr = malloc_new_(size_in_bytes);

   Call malloc, bomb if it returns NULL.  */

void *
malloc_new_ (mallocSize s)
{
  void *ptr;
  unsigned ss = s;

#if MALLOC_DEBUG && 0
  assert (s == (mallocSize) ss);/* Else alloc is too big for this
				   library/sys. */
#endif

  ptr = xmalloc (ss);
#if MALLOC_DEBUG
  memset (ptr, 126, ss);	/* Catch some kinds of errors more
				   quickly/reliably. */
#endif
  return ptr;
}

/* malloc_new_inpool_ -- Allocate new object, die if unable

   ptr = malloc_new_inpool_(NULL,MALLOC_typeUS_,"object",size_in_bytes);

   Allocate the structure and allocate a mallocArea_ to describe it, then
   add it to the list of mallocArea_s for the pool.  */

void *
malloc_new_inpool_ (mallocPool pool, mallocType_ type, const char *name, mallocSize s)
{
  void *ptr;
  mallocArea_ a;
  unsigned short i;

  if (pool == NULL)
    pool = malloc_pool_image ();

#if MALLOC_DEBUG
  assert ((pool == malloc_pool_image ())
	  || malloc_pool_find_ (pool, malloc_pool_image ()));
#endif

  ptr = malloc_new_ (s + (i = (MALLOC_DEBUG ? strlen (name) + 1 : 0)));
#if MALLOC_DEBUG
  strcpy (((char *) (ptr)) + s, name);
#endif
  a = malloc_new_ (offsetof (struct _malloc_area_, name) + i);
  switch (type)
    {				/* A little optimization to speed up killing
				   of non-permanent stuff. */
    case MALLOC_typeKP_:
    case MALLOC_typeKPR_:
      a->next = (mallocArea_) &pool->first;
      break;

    default:
      a->next = pool->first;
      break;
    }
  a->previous = a->next->previous;
  a->next->previous = a;
  a->previous->next = a;
  a->where = ptr;
#if MALLOC_DEBUG
  a->size = s;
  a->type = type;
  strcpy (a->name, name);
  pool->allocated += s;
  pool->allocations++;
#endif
  return ptr;
}

/* malloc_new_zinpool_ -- Allocate new zeroed object, die if unable

   ptr = malloc_new_zinpool_(NULL,MALLOC_typeUS_,"object",size_in_bytes,0);

   Like malloc_new_inpool_, but zeros out all the bytes in the area (assuming
   you pass it a 0).  */

void *
malloc_new_zinpool_ (mallocPool pool, mallocType_ type, const char *name, mallocSize s,
		     int z)
{
  void *ptr;

  ptr = malloc_new_inpool_ (pool, type, name, s);
  memset (ptr, z, s);
  return ptr;
}

/* malloc_pool_find_ -- See if pool is a descendant of another pool

   if (malloc_pool_find_(target_pool,parent_pool)) ...;

   Recursive descent on each of the children of the parent pool, after
   first checking the children themselves.  */

char
malloc_pool_find_ (mallocPool pool, mallocPool parent)
{
  mallocPool p;

  for (p = parent->eldest; p != (mallocPool) & parent->eldest; p = p->next)
    {
      if ((p == pool) || malloc_pool_find_ (pool, p))
	return 1;
    }
  return 0;
}

/* malloc_resize_inpool_ -- Resize existing object in pool

   ptr = malloc_resize_inpool_(NULL,MALLOC_typeUSR_,ptr,new_size,old_size);

   Find the object's mallocArea_, check it out, then do the resizing.  */

void *
malloc_resize_inpool_ (mallocPool pool, mallocType_ type UNUSED,
		       void *ptr, mallocSize ns, mallocSize os UNUSED)
{
  mallocArea_ a;

  if (pool == NULL)
    pool = malloc_pool_image ();

#if MALLOC_DEBUG
  assert ((pool == malloc_pool_image ())
	  || malloc_pool_find_ (pool, malloc_pool_image ()));
#endif

  a = malloc_find_inpool_ (pool, ptr);
#if MALLOC_DEBUG
  assert (a->type == type);
  if ((type == MALLOC_typeKSR_) || (type == MALLOC_typeKPR_))
    assert (a->size == os);
  assert (strcmp (a->name, ((char *) (ptr)) + os) == 0);
#endif
  ptr = malloc_resize_ (ptr, ns + (MALLOC_DEBUG ? strlen (a->name) + 1: 0));
  a->where = ptr;
#if MALLOC_DEBUG
  a->size = ns;
  strcpy (((char *) (ptr)) + ns, a->name);
  pool->old_sizes += os;
  pool->new_sizes += ns;
  pool->resizes++;
#endif
  return ptr;
}

/* malloc_resize_ -- Reallocate object, die if unable

   ptr = malloc_resize_(ptr,size_in_bytes);

   Call realloc, bomb if it returns NULL.  */

void *
malloc_resize_ (void *ptr, mallocSize s)
{
  int ss = s;

#if MALLOC_DEBUG && 0
  assert (s == (mallocSize) ss);/* Too big if failure here. */
#endif

  ptr = xrealloc (ptr, ss);
  return ptr;
}

/* malloc_verify_inpool_ -- Verify object

   Find the mallocArea_ for the pointer, make sure the type is proper, and
   verify both of them.  */

void
malloc_verify_inpool_ (mallocPool pool UNUSED, mallocType_ type UNUSED,
		       void *ptr UNUSED, mallocSize s UNUSED)
{
#if MALLOC_DEBUG
  mallocArea_ a;

  if (pool == NULL)
    pool = malloc_pool_image ();

  assert ((pool == malloc_pool_image ())
	  || malloc_pool_find_ (pool, malloc_pool_image ()));

  a = malloc_find_inpool_ (pool, ptr);
  assert (a->type == type);
  if ((type != MALLOC_typeUS_) && (type != MALLOC_typeUSR_))
    assert (a->size == s);
  malloc_verify_area_ (pool, a);
#endif
}