/*
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

This file is part of GNU Common Lisp, herein referred to as GCL

GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GCL 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 Library General Public 
License for more details.

You should have received a copy of the GNU Library General Public License 
along with GCL; see the file COPYING.  If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

*/

/*
	alloc.c
	IMPLEMENTATION-DEPENDENT
*/

#include "include.h"
#include "page.h"

DEFVAR("*AFTER-GBC-HOOK*",sSAafter_gbc_hookA,SI,sLnil,"");
DEFVAR("*IGNORE-MAXIMUM-PAGES*",sSAignore_maximum_pagesA,SI,sLt,"");
#define IGNORE_MAX_PAGES (sSAignore_maximum_pagesA ==0 || sSAignore_maximum_pagesA->s.s_dbind !=sLnil) 

void call_after_gbc_hook();

#ifdef DEBUG_SBRK
int debug;
char *
sbrk1(n)
     int n;
{char *ans;
 if (debug){
   printf("\n{sbrk(%d)",n);
   fflush(stdout);}
 ans= (char *)sbrk(n);
 if (debug){
   printf("->[0x%x]", ans);
   fflush(stdout);
   printf("core_end=0x%x,sbrk(0)=0x%x}",core_end,sbrk(0));
   fflush(stdout);}
 return ans;
}
#define sbrk sbrk1
#endif /* DEBUG_SBRK */

int real_maxpage = MAXPAGE;
int new_holepage;

#define	available_pages	\
	(real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)


#ifdef UNIX
extern char *sbrk();
#endif

#ifdef BSD
#include <sys/time.h>
#include <sys/resource.h>
struct rlimit data_rlimit;
/* extern char etext; */
#endif

int reserve_pages_for_signal_handler =30;

/* If  (n >= 0 ) return pointer to n pages starting at heap end,
   These must come from the hole, so if that is exhausted you have
   to gc and move the hole.
   if  (n < 0) return pointer to n pages starting at heap end,
   but don't worry about the hole.   Basically just make sure
   the space is available from the Operating system.
   If not in_signal_handler then try to keep a minimum of
   reserve_pages_for_signal_handler pages on hand in the hole
 */
char *
alloc_page(n)
int n;
{
	char *e;
	int m;
	e = heap_end;
	if (n >= 0) {
		if (n >=
		    (holepage - (in_signal_handler? 0 :
				 reserve_pages_for_signal_handler
				)))
		    {
			holepage = new_holepage + n;

			{int in_sgc=sgc_enabled;
			 if (in_sgc) sgc_quit();
			if(in_signal_handler)
			  {fprintf(stderr,
				   "Cant do relocatable gc in signal handler. \
Try to allocate more space to save for allocation during signals: \
eg to add 20 more do (si::set-hole-size %d %d)\n...start over ", new_holepage, 20+ reserve_pages_for_signal_handler); fflush(stderr); exit(1);}

			GBC(t_relocatable);
			if (in_sgc)
			  {sgc_start();
			   /* starting sgc can use up some pages
			      and may move heap end, so start over
			    */
			   return alloc_page(n);}
		       }
		}
		holepage -= n;
		if (heap_end == core_end)
		  /* can happen when mallocs occur before rel block set up..*/
		  { sbrk(PAGESIZE*n) ;
		    core_end += PAGESIZE*n;
		  }
		heap_end += PAGESIZE*n;
		return(e);
	}
     else
       /* n < 0 , then this says ensure there are -n pages
	  starting at heap_end, and return pointer to heap_end */
      {
	n = -n;
	m = (core_end - heap_end)/PAGESIZE;
	if (n <= m)
		return(e);

	IF_ALLOCATE_ERR error("Can't allocate.  Good-bye!");
#ifdef SGC
	if (sgc_enabled)
	  make_writable(page(core_end),page(core_end)+n-m);

#endif	
	core_end += PAGESIZE*(n - m);
	return(e);}
}

void
add_page_to_freelist(p,tm)
     char *p;
     struct typemanager *tm;
{short t,size;
 int i=tm->tm_nppage,fw;
 int nn;
 object x,f;
 t=tm->tm_type;
#ifdef SGC
 nn=page(p);
 if (sgc_enabled)
   { if (!WRITABLE_PAGE_P(nn)) make_writable(nn,nn+1);}
#endif
 type_map[page(p)]= t;
 size=tm->tm_size;
 f=tm->tm_free;
 x= (object)p;
 x->d.t=t;
 x->d.m=FREE;
#ifdef SGC
 if (sgc_enabled && tm->tm_sgc)
   {x->d.s=SGC_RECENT;
    sgc_type_map[page(x)] = (SGC_PAGE_FLAG | SGC_TEMP_WRITABLE);}
 else x->d.s = SGC_NORMAL;
 
 /* array headers must be always writable, since a write to the
    body does not touch the header.   It may be desirable if there
    are many arrays in a system to make the headers not writable,
    but just SGC_TOUCH the header each time you write to it.   this
    is what is done with t_structure */
  if (t== (tm_of(t_array)->tm_type))
   sgc_type_map[page(x)] |= SGC_PERM_WRITABLE;
   
#endif 
 fw= *(int *)x;
 while (--i >= 0)
   { *(int *)x=fw;
     SET_LINK(x,f);
     f=x;
     x= (object) ((char *)x + size);
   }
 tm->tm_free=f;
 tm->tm_nfree += tm->tm_nppage;
 tm->tm_npage++;
}

object
type_name(t)
     int t;
{ return make_simple_string(tm_table[(int)t].tm_name+1);}


void
call_after_gbc_hook(t)
{ if (sSAafter_gbc_hookA && sSAafter_gbc_hookA->s.s_dbind!= Cnil)
    { set_up_string_register(tm_table[(int)t].tm_name+1);
      ifuncall1(sSAafter_gbc_hookA->s.s_dbind,intern(string_register,system_package));
    }
}

#define PERCENT_FREE(tm)  ((tm->tm_percent_free ? tm->tm_percent_free : 10)/100.0)


object
alloc_object(t)
enum type t;
{
	 object obj;
	 struct typemanager *tm;
	 int i;
	 char *p;
	 object x, f;

ONCE_MORE:
	tm = tm_of(t);

        CHECK_INTERRUPT;	 

	obj = tm->tm_free;
	if (obj == OBJNULL) {
		if (tm->tm_npage >= tm->tm_maxpage)
			goto CALL_GBC;
		if (available_pages < 1) {
		  if (sSAignore_maximum_pagesA) {
			sSAignore_maximum_pagesA->s.s_dbind = Cnil;
			goto CALL_GBC;
		      }
		}
		p = alloc_page(1);
		add_page_to_freelist(p,tm);
		obj = tm->tm_free;
		if (tm->tm_npage >= tm->tm_maxpage)
			goto CALL_GBC;
	}
	tm->tm_free = OBJ_LINK(obj);
	--(tm->tm_nfree);
	(tm->tm_nused)++;
	obj->d.t = (short)t;
	obj->d.m = FALSE;
	return(obj);
#define TOTAL_THIS_TYPE(tm) \
	(tm->tm_nppage * (sgc_enabled ? sgc_count_type(tm->tm_type) : tm->tm_npage))
CALL_GBC:
	GBC(tm->tm_type);
	if (tm->tm_nfree == 0 ||
	    ((float)tm->tm_nfree)  <   (PERCENT_FREE(tm) * TOTAL_THIS_TYPE(tm)))
		goto EXHAUSTED;
	call_after_gbc_hook(t);
	goto ONCE_MORE;

EXHAUSTED:
	if (IGNORE_MAX_PAGES) {
		if (tm->tm_maxpage/2 <= 0)
			tm->tm_maxpage += 1;
		else
			tm->tm_maxpage += tm->tm_maxpage/2;
		call_after_gbc_hook(t);
		goto ONCE_MORE;
	}
	GBC_enable = FALSE;
	vs_push(type_name(t));
	vs_push(make_fixnum(tm->tm_npage));
	GBC_enable = TRUE;
	CEerror("The storage for ~A is exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE to expand the space.",
		"Continues execution.",
		2, vs_top[-2], vs_top[-1]);
	vs_pop;
	vs_pop;
	call_after_gbc_hook(t);
	goto ONCE_MORE;
}

grow_linear(old,fract,grow_min,grow_max)
     int old,grow_min,grow_max,fract;
{int delt;
 if(fract==0) fract=50;
 if(grow_min==0) grow_min=1;
 if(grow_max==0) grow_max=1000;
 delt=(old*fract)/100;
 delt= (delt < grow_min ? grow_min:
	delt > grow_max ? grow_max:
	delt);
 return old + delt;}

object
make_cons(a, d)
object a, d;
{
	 object obj;
	 int i;
	 char *p;
	 object x, f;
	struct typemanager *tm=(&tm_table[(int)t_cons]);
/* #define	tm	(&tm_table[(int)t_cons])*/

ONCE_MORE:
        CHECK_INTERRUPT;
	obj = tm->tm_free;
	if (obj == OBJNULL) {
		if (tm->tm_npage >= tm->tm_maxpage)
			goto CALL_GBC;
		if (available_pages < 1) {
		   if(sSAignore_maximum_pagesA) {
			sSAignore_maximum_pagesA->s.s_dbind = Cnil;
			goto CALL_GBC;
		      }
		}
		p = alloc_page(1);
		add_page_to_freelist(p,tm);
		obj = tm->tm_free ;
		if (tm->tm_npage >= tm->tm_maxpage)
			goto CALL_GBC;
	}
	tm->tm_free = OBJ_LINK(obj);
	--(tm->tm_nfree);
	(tm->tm_nused)++;
	obj->c.t = (short)t_cons;
	obj->c.m = FALSE;
	obj->c.c_car = a;
	obj->c.c_cdr = d;
	return(obj);

CALL_GBC:
	GBC(t_cons);
	if (tm->tm_nfree == 0 ||
	    (float)tm->tm_nfree   <  PERCENT_FREE(tm) * TOTAL_THIS_TYPE(tm))
		goto EXHAUSTED;
	call_after_gbc_hook(t_cons);
	goto ONCE_MORE;

EXHAUSTED:
	if (IGNORE_MAX_PAGES) {
	  tm->tm_maxpage =
	    grow_linear(tm->tm_maxpage,tm->tm_growth_percent,
			tm->tm_min_grow,tm->tm_max_grow);
	  call_after_gbc_hook(t_cons);
	  goto ONCE_MORE;
	}
	GBC_enable = FALSE;
	vs_push(make_fixnum(tm->tm_npage));
	GBC_enable = TRUE;
	CEerror("The storage for CONS is exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE to expand the space.",
		"Continues execution.",
		1, vs_top[-1]);
	vs_pop;
	call_after_gbc_hook(t_cons);
	goto ONCE_MORE;
#undef	tm
}


object on_stack_cons(x,y)
     object x,y;
{object p = (object) alloca_val;
 p->c.t= (short)t_cons;
 p->c.m=FALSE;
 p->c.c_car=x;
 p->c.c_cdr=y;
 return p;
}


DEFUN("ALLOCATED",object,fSallocated,SI
   ,2,2,NONE,OO,OO,OO,OO,"")(typ)
object typ;
{ struct typemanager *tm=(&tm_table[t_from_type(typ)]);
  tm = & tm_table[tm->tm_type];
  if (tm->tm_type == t_relocatable)
    { tm->tm_npage = (rb_end-rb_start)/PAGESIZE;
      tm->tm_nfree = rb_end -rb_pointer;
    }
  else if (tm->tm_type == t_contiguous)
    { int cbfree =0;
      struct contblock **cbpp;
      for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link)
	  cbfree += (*cbpp)->cb_size ;
      tm->tm_nfree = cbfree;
    }
  
  RETURN(6,object,make_fixnum(tm->tm_nfree),
	    (RV(make_fixnum(tm->tm_npage)),
	     RV(make_fixnum(tm->tm_maxpage)),
	     RV(make_fixnum(tm->tm_nppage)),
	     RV(make_fixnum(tm->tm_gbccount)),
	     RV(make_fixnum(tm->tm_nused))
	     ));
}
 
DEFUN("RESET-NUMBER-USED",object,fSreset_number_used,SI,0,1,NONE,OO,OO,OO,OO,"")(typ)
     object typ;
{int i;
 if (VFUN_NARGS == 1)
   { tm_table[t_from_type(typ)].tm_nused = 0;}
 else
 for (i=0; i <= t_relocatable ; i++)
   { tm_table[i].tm_nused = 0;}
  RETURN1(sLnil);
}


char *
alloc_contblock(n)
int n;
{
	 char *p;
	 struct contblock **cbpp;
	 int i;
	 int m;
	 bool g;


/*
	printf("allocating %d-byte contiguous block...\n", n);
*/

	g = FALSE;
	n = ROUND_UP_PTR(n);

ONCE_MORE:
	 CHECK_INTERRUPT;
	for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link)
		if ((*cbpp)->cb_size >= n) {
			p = (char *)(*cbpp);
			i = (*cbpp)->cb_size - n;
			*cbpp = (*cbpp)->cb_link;
			--ncb;
			insert_contblock(p+n, i);
			return(p);
		}
	m = (n + PAGESIZE - 1)/PAGESIZE;
       if(sSAignore_maximum_pagesA) {
	if (ncbpage + m > maxcbpage || available_pages < m) {
		if (available_pages < m)
			sSAignore_maximum_pagesA->s.s_dbind = Cnil;
		if (!g) {
			GBC(t_contiguous);
			g = TRUE;
			call_after_gbc_hook(t_contiguous);
			goto ONCE_MORE;
		}
		if (IGNORE_MAX_PAGES)
		  {struct typemanager *tm = &tm_table[(int)t_contiguous];
		   maxcbpage=grow_linear(maxcbpage,tm->tm_growth_percent,
			      tm->tm_min_grow, tm->tm_max_grow);
			g = FALSE;
			call_after_gbc_hook(t_contiguous);
			goto ONCE_MORE;
		}
		vs_push(make_fixnum(ncbpage));
		CEerror("Contiguous blocks exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
			"Continues execution.", 1, vs_head);
		vs_pop;
		g = FALSE;
		call_after_gbc_hook(t_contiguous);
		goto ONCE_MORE;
	}
      }
	p = alloc_page(m);

	for (i = 0;  i < m;  i++)
		type_map[page(p) + i] = (char)t_contiguous;
	ncbpage += m;
	insert_contblock(p+n, PAGESIZE*m - n);
	return(p);
}


insert_contblock(p, s)
char *p;
int s;
{
	struct contblock **cbpp, *cbp;

	if (s < CBMINSIZE)
		return;
	ncb++;
	cbp = (struct contblock *)p;
	cbp->cb_size = s;
	for (cbpp = &cb_pointer;  *cbpp;  cbpp = &((*cbpp)->cb_link))
		if ((*cbpp)->cb_size >= s) {
			cbp->cb_link = *cbpp;
			*cbpp = cbp;
			return;
		}
	cbp->cb_link = NULL;
	*cbpp = cbp;
}

char *
alloc_relblock(n)
int n;
{
	 char *p;
	 bool g;

	int i;

/*
	printf("allocating %d-byte relocatable block...\n", n);
*/

	g = FALSE;
	n = ROUND_UP_PTR(n);

ONCE_MORE:
        CHECK_INTERRUPT;

	if (rb_limit - rb_pointer < n) {
		if (!g && in_signal_handler == 0) {
			GBC(t_relocatable);
			g = TRUE;
			{ float f1 = (float)(rb_limit - rb_pointer),
				f2 = (float)(rb_limit - rb_start);

				if ((float)f1 < PERCENT_FREE(tm_of(t_relocatable)) * f2) 
				;
			else
			  {	call_after_gbc_hook(t_relocatable);
				goto ONCE_MORE;
					      }}
		}
		if (IGNORE_MAX_PAGES)
		  {struct typemanager *tm = &tm_table[(int)t_relocatable];
		   nrbpage=grow_linear(i=nrbpage,tm->tm_growth_percent,
			      tm->tm_min_grow, tm->tm_max_grow);
		   if (available_pages < 0)
		     nrbpage = i;
		   else {
			  rb_end +=  (PAGESIZE* (nrbpage -i));
			  rb_limit = rb_end - 2*RB_GETA;
			  if (page(rb_end) - page(heap_end) !=
			      holepage + nrbpage)
			    FEerror("bad rb_end",0);
			  alloc_page(-( nrbpage + holepage));
			  g = FALSE;
			  call_after_gbc_hook(t_relocatable);
			  goto ONCE_MORE;
			}
		}
		if (rb_limit > rb_end - 2*RB_GETA)
			error("relocatable blocks exhausted");
		rb_limit += RB_GETA;
		vs_push(make_fixnum(nrbpage));
		CEerror("Relocatable blocks exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE-RELOCATABLE-PAGES to expand the space.",
			"Continues execution.", 1, vs_head);
		vs_pop;
		g = FALSE;
		call_after_gbc_hook(t_relocatable);
		goto ONCE_MORE;
	}
	p = rb_pointer;
	rb_pointer += n;
	return(p);
}

init_tm(t, name, elsize, nelts,sgc)
enum type t;
char name[];
int elsize, nelts;
{
	int i, j;
	int maxpage;
	/* round up to next number of pages */
	maxpage = (((nelts * elsize) + PAGESIZE -1)/PAGESIZE);
	tm_table[(int)t].tm_name = name;
	for (j = -1, i = 0;  i < (int)t_end;  i++)
		if (tm_table[i].tm_size != 0 &&
		    tm_table[i].tm_size >= elsize &&
		    (j < 0 || tm_table[j].tm_size > tm_table[i].tm_size))
			j = i;
	if (j >= 0) {
		tm_table[(int)t].tm_type = (enum type)j;
		tm_table[j].tm_maxpage += maxpage;
#ifdef SGC		
		tm_table[j].tm_sgc += sgc;
#endif
		return;
	}
	tm_table[(int)t].tm_type = t;
	tm_table[(int)t].tm_size = ROUND_UP_PTR(elsize);
	tm_table[(int)t].tm_nppage = PAGESIZE/ROUND_UP_PTR(elsize);
	tm_table[(int)t].tm_free = OBJNULL;
	tm_table[(int)t].tm_nfree = 0;
	tm_table[(int)t].tm_nused = 0;
	/*tm_table[(int)t].tm_npage = 0; */  /* dont zero nrbpage.. */
	tm_table[(int)t].tm_maxpage = maxpage;
	tm_table[(int)t].tm_gbccount = 0;
#ifdef SGC	
	tm_table[(int)t].tm_sgc = sgc;
	tm_table[(int)t].tm_sgc_max = 3000;
	tm_table[(int)t].tm_sgc_minfree = (int)
	  (0.4 * tm_table[(int)t].tm_nppage);
#endif

}

set_maxpage()
{
  /* This is run in init.  Various initializations including getting
     maxpage are here */ 
#ifdef SGC
  page_multiple=getpagesize()/PAGESIZE;
  if (page_multiple==0) error("PAGESIZE must be factor of getpagesize()");
  if (sgc_enabled)
    {memory_protect(1);}
  if (~(-MAXPAGE) != MAXPAGE-1) error("MAXPAGE must be power of 2");
  if (core_end)
     bzero(&sgc_type_map[ page(core_end)],MAXPAGE- page(core_end));
#else
  page_multiple=1;
#endif
  
SET_REAL_MAXPAGE;

}





init_alloc()
{
	int i, j;
	struct typemanager *tm;
	char *p, *q;
	enum type t;
	int c;
	static initialized;

	if (initialized) return;
	initialized=1;
	

#ifndef DONT_NEED_MALLOC	

	{
		extern object malloc_list;
		malloc_list = Cnil;
		enter_mark_origin(&malloc_list);
	}
#endif	

	holepage = INIT_HOLEPAGE;
	new_holepage = HOLEPAGE;
	nrbpage = INIT_NRBPAGE;

	set_maxpage();

#ifdef __linux__
	/* Some versions of the Linux startup code are broken.
	   For these, the first call to sbrk() fails, but
	   subsequent calls are o.k.
	   */
	if ( (int)sbrk(0) == -1 )
	  {
	    if ( (int)sbrk(0) == -1 )
	      {
		fputs("FATAL Linux sbrk() error\n", stderr);
		exit(1);
	      }
	    fputs("WARNING: Non-fatal Linux sbrk() error\n", stderr);
	  }
#endif

	INIT_ALLOC;
	
	alloc_page(-(holepage + nrbpage));

	rb_start = rb_pointer = heap_end + PAGESIZE*holepage;
	rb_end = rb_start + PAGESIZE*nrbpage;
	rb_limit = rb_end - 2*RB_GETA;
#ifdef SGC	
	tm_table[(int)t_relocatable].tm_sgc = 50;
#endif
	
	for (i = 0;  i < MAXPAGE;  i++)
		type_map[i] = (char)t_other;

	init_tm(t_fixnum, "NFIXNUM",
		sizeof(struct fixnum_struct), 8192,20);
	init_tm(t_cons, ".CONS", sizeof(struct cons), 65536 ,50 );
	init_tm(t_structure, "SSTRUCTURE", sizeof(struct structure), 5461,0 );
	init_tm(t_cfun, "fCFUN", sizeof(struct cfun), 4096,0  );
	init_tm(t_sfun, "gSFUN", sizeof(struct sfun),409,0 );
	init_tm(t_string, "\"STRING", sizeof(struct string), 5461,1  );
	init_tm(t_array, "aARRAY", sizeof(struct array), 4681,1 );
	init_tm(t_symbol, "|SYMBOL", sizeof(struct symbol), 3640,1 );
	init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum), 2730,0 );
	init_tm(t_ratio, "RRATIONAL", sizeof(struct ratio), 170,0 );
	init_tm(t_shortfloat, "FSHORT-FLOAT",
		sizeof(struct shortfloat_struct), 256 ,1);
	init_tm(t_longfloat, "LLONG-FLOAT",
		sizeof(struct longfloat_struct), 170 ,0);
	init_tm(t_complex, "CCOMPLEX", sizeof(struct complex), 170 ,0);
	init_tm(t_character,"#CHARACTER",sizeof(struct character), 256 ,0);
	init_tm(t_package, ":PACKAGE", sizeof(struct package), 2*PAGESIZE / sizeof(struct package),0);
	init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct hashtable), 78,0 );
	init_tm(t_vector, "vVECTOR", sizeof(struct vector), 146 ,0);
	init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct bitvector), 73 ,0);
	init_tm(t_stream, "sSTREAM", sizeof(struct stream), 78 ,0);
	init_tm(t_random, "$RANDOM-STATE", sizeof(struct random), 256 ,0);
	init_tm(t_readtable, "rREADTABLE", sizeof(struct readtable), 256 ,0);
	init_tm(t_pathname, "pPATHNAME", sizeof(struct pathname), 73 ,0);
	init_tm(t_cclosure, "cCCLOSURE", sizeof(struct cclosure), 85 ,0);
	init_tm(t_closure, "cCLOSURE", sizeof(struct cclosure), 85 ,0);
	init_tm(t_vfun, "VVFUN", sizeof(struct vfun), 102 ,0);
	init_tm(t_gfun, "gGFUN", sizeof(struct sfun), 0 ,0);
	init_tm(t_afun, "AAFUN", sizeof(struct sfun), 0 ,0);
	init_tm(t_cfdata, "cCFDATA", sizeof(struct cfdata), 102 ,0);
	init_tm(t_spice, "!SPICE", sizeof(struct spice), 4096 ,0);
	init_tm(t_relocatable, "%RELOCATABLE-BLOCKS", 1000,0,20);
	init_tm(t_contiguous, "_CONTIGUOUS-BLOCKS", 1001,0,20);
	tm_table[t_relocatable].tm_nppage = PAGESIZE;
	tm_table[t_contiguous].tm_nppage = PAGESIZE;


	ncb = 0;
	ncbpage = 0;
	maxcbpage = 512;
	
}

DEFUN("STATICP",object,fSstaticp,SI,1,1,NONE,OO,OO,OO,OO,"Tell if the string or vector is static") (x)
object x;
{ RETURN1((inheap(x->ust.ust_self) ? sLt : sLnil));
}

cant_get_a_type()
{
	FEerror("Can't get a type.", 0);
}

DEFUNO("ALLOCATE",object,fSallocate,SI
   ,2,3,NONE,OO,IO,OO,OO,siLallocate,"")(type,npages,va_alist)
object type;
int npages;
va_dcl
{	int nargs=VFUN_NARGS;
	object really_do;
	va_list ap;
	struct typemanager *tm;
	int c, i;
	char *p, *pp;
	object f, x;
	int t;

	{va_start(ap);
	 if (nargs>=3) really_do=va_arg(ap,object);else goto LDEFAULT3;
	 goto LEND_VARARG;
       LDEFAULT3: really_do = Cnil;
       LEND_VARARG: va_end(ap);}
	


	CHECK_ARG_RANGE(2,3);
	t= t_from_type(type);
	if  (npages <= 0)
		FEerror("Allocate takes positive argument.", 1,
			make_fixnum(npages));
	tm = tm_of(t);
	if (tm->tm_npage > npages) {npages=tm->tm_npage;}
	tm->tm_maxpage = npages;
	if (really_do != Cnil &&
	    tm->tm_maxpage > tm->tm_npage)
	  goto ALLOCATE;
	RETURN1(Ct);

ALLOCATE:
	if (t == t_contiguous) 
	  FUNCALL(2,fSallocate_contiguous_pages(npages,really_do));
	  
        else
  	  if (t==t_relocatable) 
	    FUNCALL(2,fSallocate_relocatable_pages(npages,really_do));
        else{
	  
	if (available_pages < tm->tm_maxpage - tm->tm_npage ||
	    (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) {
	FEerror("Can't allocate ~D pages for ~A.", 2,
		make_fixnum(npages), (make_simple_string(tm->tm_name+1)));
	}
	    for (;  tm->tm_npage < tm->tm_maxpage;  pp += PAGESIZE)
	      add_page_to_freelist(pp,tm);}

	RETURN1(Ct);
}

t_from_type(type)
     object type;
{
 
 int i;
 check_type_or_symbol_string(&type);
 for (i= (int)t_start ; i < (int)t_other ; i++)
   {struct typemanager *tm = &tm_table[i];
   if(tm->tm_name &&
      0==strncmp((tm->tm_name)+1,type->st.st_self,type->st.st_fillp)
      )
     return i;}
 FEerror("Unrecognized type",0);
}
/* When sgc is enabled the TYPE should have at least MIN pages of sgc type,
   and at most MAX of them.   Each page should be FREE_PERCENT free
   when the sgc is turned on.  FREE_PERCENT is an integer between 0 and 100. 
   */

DEFUN("ALLOCATE-SGC",object,fSallocate_sgc,SI
   ,4,4,NONE,OO,II,II,OO,"")(type,min,max,free_percent)
     object type;
     int min,max,free_percent;
{int m,t=t_from_type(type);
 struct typemanager *tm;
 object res;
 tm=tm_of(t);
  res= list(3,make_fixnum(tm->tm_sgc),
	   make_fixnum(tm->tm_sgc_max),
	   make_fixnum((100*tm->tm_sgc_minfree)/tm->tm_nppage));
 
 if(min<0 || max< min || min > 3000 || free_percent < 0 || free_percent > 100)
    goto END;
 tm->tm_sgc_max=max;
 tm->tm_sgc=min;
 tm->tm_sgc_minfree= (tm->tm_nppage *free_percent) /100;
 END:
 RETURN1(res);
}

/* Growth of TYPE will be by at least MIN pages and at most MAX pages.
   It will try to grow PERCENT of the current pages.
   */
DEFUN("ALLOCATE-GROWTH",object,fSallocate_growth,SI,5,5,NONE,OO,II,II,OO,"")
     (type,min,max,percent,percent_free)
int min,max,percent,percent_free;
object type;
{int  t=t_from_type(type);
 struct typemanager *tm=tm_of(t);
 object res;
 res= list(4,make_fixnum(tm->tm_min_grow),
	   make_fixnum(tm->tm_max_grow),
	   make_fixnum(tm->tm_growth_percent),
	   make_fixnum(tm->tm_percent_free));
 
 if(min<0 || max< min || min > 3000 || percent < 0 || percent > 500 
    || percent_free <0 || percent_free > 100
    )
    goto END;
 tm->tm_max_grow=max;
 tm->tm_min_grow=min;
 tm->tm_growth_percent= percent;
 tm->tm_percent_free= percent_free;
 END:
 RETURN1(res);
}



DEFUNO("ALLOCATE-CONTIGUOUS-PAGES",object,fSallocate_contiguous_pages,SI
   ,1,2,NONE,OI,OO,OO,OO,siLalloc_contpage,"")(npages,va_alist)
int npages;
va_dcl
{	int nargs=VFUN_NARGS;
	object really_do;
	va_list ap;
	int m;
	char *p;

	{ va_start(ap);
	  if (nargs>=2) really_do=va_arg(ap,object);else goto LDEFAULT2;
	  goto LEND_VARARG;
	LDEFAULT2: really_do = Cnil ;
	LEND_VARARG: va_end(ap);}


	CHECK_ARG_RANGE(1,2);
	if  (npages  < 0)
		FEerror("Allocate requires positive argument.", 0);
	if (ncbpage > npages)
	  { printf("Allocate contiguous %d: %d already there pages",npages,ncbpage);
	    npages=ncbpage;}
	maxcbpage = npages;
	if (really_do == Cnil) { RETURN1(Ct);}
	m = maxcbpage - ncbpage;
	if (available_pages < m || (p = alloc_page(m)) == NULL)
		FEerror("Can't allocate ~D pages for contiguous blocks.",
			1, make_fixnum(npages));
	{int i ;
	for (i = 0;  i < m;  i++)
		type_map[page(p + PAGESIZE*i)] = (char)t_contiguous;
        }
	ncbpage += m;
	insert_contblock(p, PAGESIZE*m);
	RETURN1(Ct);
}


DEFUNO("ALLOCATED-CONTIGUOUS-PAGES",object,fSallocated_contiguous_pages,SI
   ,0,0,NONE,OO,OO,OO,OO,siLncbpage,"")()
{
	/* 0 args */
	RETURN1((make_fixnum(ncbpage)));
}

DEFUNO("MAXIMUM-CONTIGUOUS-PAGES",object,fSmaximum_contiguous_pages,SI
   ,0,0,NONE,OO,OO,OO,OO,siLmaxcbpage,"")()
{
	/* 0 args */
	RETURN1((make_fixnum(maxcbpage)));
}


DEFUNO("ALLOCATE-RELOCATABLE-PAGES",object,fSallocate_relocatable_pages,SI
   ,1,2,NONE,OI,OO,OO,OO,siLalloc_relpage,"")(npages,va_alist)
int npages;
va_dcl
{	int nargs=VFUN_NARGS;
	object really_do;
	va_list ap;

	char *p;

	{ va_start(ap);
	  if (nargs>=2) really_do=va_arg(ap,object);else goto LDEFAULT2;
	  goto LEND_VARARG;
	LDEFAULT2: really_do = Cnil ;
	LEND_VARARG: va_end(ap);}

	CHECK_ARG_RANGE(1,2);
	if (npages  <= 0)
		FEerror("Requires positive arg",0);
	if (nrbpage > npages && rb_pointer >= rb_start + PAGESIZE*npages - 2*RB_GETA
	 || 2*npages > real_maxpage-page(heap_end)-new_holepage-real_maxpage/32)
	  FEerror("Can't set the limit for relocatable blocks to ~D.",
		  1, make_fixnum(npages));
	rb_end += (npages-nrbpage)*PAGESIZE;
	nrbpage = npages;
	rb_limit = rb_end - 2*RB_GETA;
	alloc_page(-(holepage + nrbpage));
	vs_top = vs_base;
	vs_push(Ct);
	RETURN1(make_fixnum(npages));
}

DEFUNO("ALLOCATED-RELOCATABLE-PAGES",object,fSallocated_relocatable_pages,SI
   ,0,0,NONE,OO,OO,OO,OO,siLnrbpage,"")()
{
	/* 0 args */
	RETURN1(make_fixnum(nrbpage));
}

DEFUNO("GET-HOLE-SIZE",object,fSget_hole_size,SI
   ,0,0,NONE,OO,OO,OO,OO,siLget_hole_size,"")()
{
	/* 0 args */
	RETURN1((make_fixnum(new_holepage)));
}

DEFUNO("SET-HOLE-SIZE",object,fSset_hole_size,SI
   ,1,2,NONE,OI,IO,OO,OO,siLset_hole_size,"")(npages,va_alist)
int npages;
va_dcl
{	int nargs=VFUN_NARGS;
	int reserve;
	va_list ap;
	{ va_start(ap);
	  if (nargs>=2) reserve=va_arg(ap,int);else goto LDEFAULT2;
	  goto LEND_VARARG;
	LDEFAULT2: reserve = 30;
	LEND_VARARG: va_end(ap);}

	if (npages < 1 ||
	    npages > real_maxpage - page(heap_end)
	    - 2*nrbpage - real_maxpage/32)
		FEerror("Illegal value for the hole size.", 0);
	new_holepage = npages;
	if (VFUN_NARGS ==2)
	  {
	    if (reserve <0 || reserve > new_holepage)
	      FEerror("Illegal value for the hole size.", 0);
	    reserve_pages_for_signal_handler = reserve;}

	RETURN2(make_fixnum(npages),
		make_fixnum(reserve_pages_for_signal_handler));
}


init_alloc_function()
{
}

object malloc_list;

#ifndef DONT_NEED_MALLOC

/*
	UNIX malloc simulator.

	Used by
		getwd, popen, etc.
*/



/*  If this is defined, substitute the fast gnu malloc for the slower
    version below.   If you have many calls to malloc this is worth
    your while.   I have only tested it slightly under 4.3Bsd.   There
    the difference in a test run with 120K mallocs and frees,
    was 29 seconds to 1.9 seconds */
    
#ifdef GNU_MALLOC
#include "malloc.c"
#else

char *
malloc(size)
int size;
{
	object x;

	if (GBC_enable==0 && initflag ==0)
	  { init_alloc();}
      

	x = alloc_simple_string(size);

	x->st.st_self = alloc_contblock(size);
#ifdef SGC
	perm_writable(x->st.st_self,size);
#endif
	malloc_list = make_cons(x, malloc_list);

	return(x->st.st_self);
}


void
free(ptr)
#ifndef NO_VOID_STAR
void *
#else
char *
#endif  
  ptr;
{
	object *p;
 	object endp_temp;
	if (ptr == 0)
	  return;
	for (p = &malloc_list; *p && !endp(*p);  p = &((*p)->c.c_cdr))
		if ((*p)->c.c_car->st.st_self == ptr) {
			insert_contblock((*p)->c.c_car->st.st_self,
					 (*p)->c.c_car->st.st_dim);
			(*p)->c.c_car->st.st_self = NULL;
			*p = (*p)->c.c_cdr;
			return ;
		}
#ifdef NOFREE_ERR
	return ;
#else	
	FEerror("free(3) error.",0);
	return;
#endif	
}

char *
realloc(ptr, size)
char *ptr;
int size;
{
	object x;
	int i, j;
 	object endp_temp;
	
	if(ptr == NULL) return malloc(size);
	for (x = malloc_list;  !endp(x);  x = x->c.c_cdr)
		if (x->c.c_car->st.st_self == ptr) {
			x = x->c.c_car;
			if (x->st.st_dim >= size) {
				x->st.st_fillp = size;
				return(ptr);
			} else {
				j = x->st.st_dim;
				x->st.st_self = alloc_contblock(size);
				x->st.st_fillp = x->st.st_dim = size;
				for (i = 0;  i < size;  i++)
					x->st.st_self[i] = ptr[i];
				insert_contblock(ptr, j);
				return(x->st.st_self);
			}
		}
	FEerror("realloc(3) error.", 0);
}

#endif /* gnumalloc */


char *
calloc(nelem, elsize)
int nelem, elsize;
{
	char *ptr;
	int i;

	ptr = malloc(i = nelem*elsize);
	while (--i >= 0)
		ptr[i] = 0;
	return(ptr);
}


cfree(ptr)
char *ptr;
{
	free(ptr);

}

#endif


#ifndef GNUMALLOC
char *
memalign(align,size)
     int align,size;
{ object x = alloc_simple_string(size);
  x->st.st_self = ALLOC_ALIGNED(alloc_contblock,size,align);
  malloc_list = make_cons(x, malloc_list);
  return x->st.st_self;
}
#ifdef WANT_VALLOC
char *
valloc(size)
int size;     
{ return memalign(getpagesize(),size);}
#endif

#endif
