This is alloc.c in view mode; [Download] [Up]
/*
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,"");
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) {
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 (symbol_value(sSAignore_maximum_pagesA) != Cnil) {
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) {
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 (symbol_value(sSAignore_maximum_pagesA) != Cnil) {
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 (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 (symbol_value(sSAignore_maximum_pagesA) != Cnil)
{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 (symbol_value(sSAignore_maximum_pagesA) != Cnil)
{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;
}
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
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));
}
#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
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.