home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / alloc.c next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  23.0 KB  |  1,049 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     alloc.c
  24.     IMPLEMENTATION-DEPENDENT
  25. */
  26.  
  27. #include "include.h"
  28.  
  29.  
  30. object Vignore_maximum_pages;
  31.  
  32.  
  33. #include "page.h"
  34.  
  35. #ifdef DEBUG_SBRK
  36. int debug;
  37. char *
  38. sbrk1(n)
  39.      int n;
  40. {char *ans;
  41.  if (debug){
  42.    printf("\n{sbrk(%d)",n);
  43.    fflush(stdout);}
  44.  ans= (char *)sbrk(n);
  45.  if (debug){
  46.    printf("->[0x%x]", ans);
  47.    fflush(stdout);
  48.    printf("core_end=0x%x,sbrk(0)=0x%x}",core_end,sbrk(0));
  49.    fflush(stdout);}
  50.  return ans;
  51. }
  52. #define sbrk sbrk1
  53. #endif /* DEBUG_SBRK */
  54.  
  55. int real_maxpage = MAXPAGE;
  56. int new_holepage;
  57.  
  58. #define    available_pages    \
  59.     (real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
  60.  
  61.  
  62. #ifdef UNIX
  63. extern char *sbrk();
  64. #endif
  65.  
  66. #ifdef BSD
  67. #include <sys/time.h>
  68. #include <sys/resource.h>
  69. struct rlimit data_rlimit;
  70. extern char etext;
  71. #endif
  72.  
  73.  
  74. /* If  (n >= 0 ) return pointer to n pages starting at heap end,
  75.    These must come from the hole, so if that is exhausted you have
  76.    to gc and move the hole.
  77.    if  (n < 0) return pointer to n pages starting at heap end,
  78.    but don't worry about the hole.   Basically just make sure
  79.    the space is available from the Operating system.
  80.  */
  81. char *
  82. alloc_page(n)
  83. int n;
  84. {
  85.     char *e;
  86.     int m;
  87.     e = heap_end;
  88.     if (n >= 0) {
  89.         if (n >= holepage) {
  90.             holepage = new_holepage + n;
  91.  
  92.             {int in_sgc=sgc_enabled;
  93.              if (in_sgc) sgc_quit();
  94.             GBC(t_relocatable);
  95.             if (in_sgc)
  96.               {sgc_start();
  97.                /* starting sgc can use up some pages
  98.                   and may move heap end, so start over
  99.                 */
  100.                return alloc_page(n);}
  101.                }
  102.         }
  103.         holepage -= n;
  104.         heap_end += PAGESIZE*n;
  105.         return(e);
  106.     }
  107.      else
  108.        /* n < 0 , then this says ensure there are -n pages
  109.       starting at heap_end, and return pointer to heap_end */
  110.       {
  111.     n = -n;
  112.     m = (core_end - heap_end)/PAGESIZE;
  113.     if (n <= m)
  114.         return(e);
  115.  
  116.     IF_ALLOCATE_ERR error("Can't allocate.  Good-bye!");
  117. #ifdef SGC
  118.     if (sgc_enabled)
  119.       make_writable(page(core_end),page(core_end)+n-m);
  120.  
  121. #endif    
  122.     core_end += PAGESIZE*(n - m);
  123.     return(e);}
  124. }
  125.  
  126. void
  127. add_page_to_freelist(p,tm)
  128.      char *p;
  129.      struct typemanager *tm;
  130. {short t,size;
  131.  int i=tm->tm_nppage,fw;
  132.  int nn;
  133.  object x,f;
  134.  t=tm->tm_type;
  135. #ifdef SGC
  136.  nn=page(p);
  137.  if (sgc_enabled)
  138.    { if (!WRITABLE_PAGE_P(nn)) make_writable(nn,nn+1);}
  139. #endif
  140.  type_map[page(p)]= t;
  141.  size=tm->tm_size;
  142.  f=tm->tm_free;
  143.  x= (object)p;
  144.  x->d.t=t;
  145.  x->d.m=FREE;
  146. #ifdef SGC
  147.  if (sgc_enabled && tm->tm_sgc)
  148.    {x->d.s=SGC_RECENT;
  149.     sgc_type_map[page(x)] = (SGC_PAGE_FLAG | SGC_TEMP_WRITABLE);}
  150.  else x->d.s = SGC_NORMAL;
  151.  
  152.  /* array headers must be always writable, since a write to the
  153.     body does not touch the header.   It may be desirable if there
  154.     are many arrays in a system to make the headers not writable,
  155.     but just SGC_TOUCH the header each time you write to it.   this
  156.     is what is done with t_structure */
  157.   if (t== (tm_of(t_array)->tm_type))
  158.    sgc_type_map[page(x)] |= SGC_PERM_WRITABLE;
  159.    
  160. #endif 
  161.  fw= *(int *)x;
  162.  while (--i >= 0)
  163.    { *(int *)x=fw;
  164.      F_LINK(x)=f;
  165.      f=x;
  166.      x= (object) ((char *)x + size);
  167.    }
  168.  tm->tm_free=f;
  169.  tm->tm_nfree += tm->tm_nppage;
  170.  tm->tm_npage++;
  171. }
  172.  
  173.  
  174.  
  175. object
  176. alloc_object(t)
  177. enum type t;
  178. {
  179.     STATIC object obj;
  180.     STATIC struct typemanager *tm;
  181.     STATIC int i;
  182.     STATIC char *p;
  183.     STATIC object x, f;
  184.  
  185. ONCE_MORE:
  186.     tm = tm_of(t);
  187.  
  188.     if (interrupt_flag) {
  189.         interrupt_flag = FALSE;
  190. #ifdef UNIX
  191.         alarm(0);
  192. #endif
  193.         terminal_interrupt(TRUE);
  194.         goto ONCE_MORE;
  195.     }
  196.     obj = tm->tm_free;
  197.     if (obj == OBJNULL) {
  198.         if (tm->tm_npage >= tm->tm_maxpage)
  199.             goto CALL_GBC;
  200.         if (available_pages < 1) {
  201.             Vignore_maximum_pages->s.s_dbind = Cnil;
  202.             goto CALL_GBC;
  203.         }
  204.         p = alloc_page(1);
  205.         add_page_to_freelist(p,tm);
  206.         obj = tm->tm_free;
  207.         if (tm->tm_npage >= tm->tm_maxpage)
  208.             goto CALL_GBC;
  209.     }
  210.     tm->tm_free = ((struct freelist *)obj)->f_link;
  211.     --(tm->tm_nfree);
  212.     (tm->tm_nused)++;
  213.     obj->d.t = (short)t;
  214.     obj->d.m = FALSE;
  215.     return(obj);
  216. #define TOTAL_THIS_TYPE(tm) \
  217.     (tm->tm_nppage * (sgc_enabled ? sgc_count_type(tm->tm_type) : tm->tm_npage))
  218. CALL_GBC:
  219.     GBC(tm->tm_type);
  220.     if (tm->tm_nfree == 0 ||
  221.         (float)tm->tm_nfree * 10.0 < (float) TOTAL_THIS_TYPE(tm))
  222.         goto EXHAUSTED;
  223.     goto ONCE_MORE;
  224.  
  225. EXHAUSTED:
  226.     if (symbol_value(Vignore_maximum_pages) != Cnil) {
  227.         if (tm->tm_maxpage/2 <= 0)
  228.             tm->tm_maxpage += 1;
  229.         else
  230.             tm->tm_maxpage += tm->tm_maxpage/2;
  231.         goto ONCE_MORE;
  232.     }
  233.     GBC_enable = FALSE;
  234.     vs_push(make_simple_string(tm_table[(int)t].tm_name+1));
  235.     vs_push(make_fixnum(tm->tm_npage));
  236.     GBC_enable = TRUE;
  237.     CEerror("The storage for ~A is exhausted.~%\
  238. Currently, ~D pages are allocated.~%\
  239. Use ALLOCATE to expand the space.",
  240.         "Continues execution.",
  241.         2, vs_top[-2], vs_top[-1]);
  242.     vs_pop;
  243.     vs_pop;
  244.     goto ONCE_MORE;
  245. }
  246.  
  247. grow_linear(old,fract,grow_min,grow_max)
  248.      int old,grow_min,grow_max,fract;
  249. {int delt;
  250.  if(fract==0) fract=50;
  251.  if(grow_min==0) grow_min=1;
  252.  if(grow_max==0) grow_max=1000;
  253.  delt=(old*fract)/100;
  254.  delt= (delt < grow_min ? grow_min:
  255.     delt > grow_max ? grow_max:
  256.     delt);
  257.  return old + delt;}
  258.  
  259. object
  260. make_cons(a, d)
  261. object a, d;
  262. {
  263.     STATIC object obj;
  264.     STATIC int i;
  265.     STATIC char *p;
  266.     STATIC object x, f;
  267.     struct typemanager *tm=(&tm_table[(int)t_cons]);
  268. /* #define    tm    (&tm_table[(int)t_cons])*/
  269.  
  270. ONCE_MORE:
  271.     if (interrupt_flag) {
  272.         interrupt_flag = FALSE;
  273. #ifdef UNIX
  274.         alarm(0);
  275. #endif
  276.         terminal_interrupt(TRUE);
  277.         goto ONCE_MORE;
  278.     }
  279.     obj = tm->tm_free;
  280.     if (obj == OBJNULL) {
  281.         if (tm->tm_npage >= tm->tm_maxpage)
  282.             goto CALL_GBC;
  283.         if (available_pages < 1) {
  284.             Vignore_maximum_pages->s.s_dbind = Cnil;
  285.             goto CALL_GBC;
  286.         }
  287.         p = alloc_page(1);
  288.         add_page_to_freelist(p,tm);
  289.         obj = tm->tm_free ;
  290.         if (tm->tm_npage >= tm->tm_maxpage)
  291.             goto CALL_GBC;
  292.     }
  293.     tm->tm_free = ((struct freelist *)obj)->f_link;
  294.     --(tm->tm_nfree);
  295.     (tm->tm_nused)++;
  296.     obj->c.t = (short)t_cons;
  297.     obj->c.m = FALSE;
  298.     obj->c.c_car = a;
  299.     obj->c.c_cdr = d;
  300.     return(obj);
  301.  
  302. CALL_GBC:
  303.     GBC(t_cons);
  304.     if (tm->tm_nfree == 0 ||
  305.         (float)tm->tm_nfree * 10.0 < (float) TOTAL_THIS_TYPE(tm))
  306.         goto EXHAUSTED;
  307.     goto ONCE_MORE;
  308.  
  309. EXHAUSTED:
  310.     if (symbol_value(Vignore_maximum_pages) != Cnil) {
  311.       tm->tm_maxpage =
  312.         grow_linear(tm->tm_maxpage,tm->tm_growth_percent,
  313.             tm->tm_min_grow,tm->tm_max_grow);
  314.         goto ONCE_MORE;
  315.     }
  316.     GBC_enable = FALSE;
  317.     vs_push(make_fixnum(tm->tm_npage));
  318.     GBC_enable = TRUE;
  319.     CEerror("The storage for CONS is exhausted.~%\
  320. Currently, ~D pages are allocated.~%\
  321. Use ALLOCATE to expand the space.",
  322.         "Continues execution.",
  323.         1, vs_top[-1]);
  324.     vs_pop;
  325.     goto ONCE_MORE;
  326. #undef    tm
  327. }
  328.  
  329.  
  330. object on_stack_cons(x,y)
  331.      object x,y;
  332. {object p = (object) alloca_val;
  333.  p->c.t= (short)t_cons;
  334.  p->c.m=FALSE;
  335.  p->c.c_car=x;
  336.  p->c.c_cdr=y;
  337.  return p;
  338. }
  339.  
  340.  
  341.  
  342.  
  343. #define    round_up(n)    (((n) + 03) & ~03)
  344.  
  345. char *
  346. alloc_contblock(n)
  347. int n;
  348. {
  349.     STATIC char *p;
  350.     STATIC struct contblock **cbpp;
  351.     STATIC int i;
  352.     STATIC int m;
  353.     STATIC bool g;
  354.     bool gg;
  355.  
  356. /*
  357.     printf("allocating %d-byte contiguous block...\n", n);
  358. */
  359.  
  360.     g = FALSE;
  361.     n = round_up(n);
  362.  
  363. ONCE_MORE:
  364.     if (interrupt_flag) {
  365.         interrupt_flag = FALSE;
  366.         gg = g;
  367.         terminal_interrupt(TRUE);
  368.         g = gg;
  369.         goto ONCE_MORE;
  370.     }
  371.     for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link)
  372.         if ((*cbpp)->cb_size >= n) {
  373.             p = (char *)(*cbpp);
  374.             i = (*cbpp)->cb_size - n;
  375.             *cbpp = (*cbpp)->cb_link;
  376.             --ncb;
  377.             insert_contblock(p+n, i);
  378.             return(p);
  379.         }
  380.     m = (n + PAGESIZE - 1)/PAGESIZE;
  381.     if (ncbpage + m > maxcbpage || available_pages < m) {
  382.         if (available_pages < m)
  383.             Vignore_maximum_pages->s.s_dbind = Cnil;
  384.         if (!g) {
  385.             GBC(t_contiguous);
  386.             g = TRUE;
  387.             goto ONCE_MORE;
  388.         }
  389.         if (symbol_value(Vignore_maximum_pages) != Cnil)
  390.           {struct typemanager *tm = &tm_table[(int)t_contiguous];
  391.            maxcbpage=grow_linear(maxcbpage,tm->tm_growth_percent,
  392.                   tm->tm_min_grow, tm->tm_max_grow);
  393.             g = FALSE;
  394.             goto ONCE_MORE;
  395.         }
  396.         vs_push(make_fixnum(ncbpage));
  397.         CEerror("Contiguous blocks exhausted.~%\
  398. Currently, ~D pages are allocated.~%\
  399. Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
  400.             "Continues execution.", 1, vs_head);
  401.         vs_pop;
  402.         g = FALSE;
  403.         goto ONCE_MORE;
  404.     }
  405.  
  406.     p = alloc_page(m);
  407.  
  408.     for (i = 0;  i < m;  i++)
  409.         type_map[page(p) + i] = (char)t_contiguous;
  410.     ncbpage += m;
  411.     insert_contblock(p+n, PAGESIZE*m - n);
  412.     return(p);
  413. }
  414.  
  415. insert_contblock(p, s)
  416. char *p;
  417. int s;
  418. {
  419.     struct contblock **cbpp, *cbp;
  420.  
  421.     if (s < CBMINSIZE)
  422.         return;
  423.     ncb++;
  424.     cbp = (struct contblock *)p;
  425.     cbp->cb_size = s;
  426.     for (cbpp = &cb_pointer;  *cbpp;  cbpp = &((*cbpp)->cb_link))
  427.         if ((*cbpp)->cb_size >= s) {
  428.             cbp->cb_link = *cbpp;
  429.             *cbpp = cbp;
  430.             return;
  431.         }
  432.     cbp->cb_link = NULL;
  433.     *cbpp = cbp;
  434. }
  435.  
  436. char *
  437. alloc_relblock(n)
  438. int n;
  439. {
  440.     STATIC char *p;
  441.     STATIC bool g;
  442.     bool gg;
  443.     int i;
  444.  
  445. /*
  446.     printf("allocating %d-byte relocatable block...\n", n);
  447. */
  448.  
  449.     g = FALSE;
  450.     n = round_up(n);
  451.  
  452. ONCE_MORE:
  453.     if (interrupt_flag) {
  454.         interrupt_flag = FALSE;
  455.         gg = g;
  456.         terminal_interrupt(TRUE);
  457.         g = gg;
  458.         goto ONCE_MORE;
  459.     }
  460.     if (rb_limit - rb_pointer < n) {
  461.         if (!g) {
  462.             GBC(t_relocatable);
  463.             g = TRUE;
  464.             { float f1 = (float)(rb_limit - rb_pointer),
  465.                 f2 = (float)(rb_limit - rb_start);
  466.  
  467.                 if (f1 * 10.0 < f2) 
  468.                 ;
  469.             else
  470.                 goto ONCE_MORE;
  471.             }
  472.         }
  473.         if (symbol_value(Vignore_maximum_pages) != Cnil)
  474.           {struct typemanager *tm = &tm_table[(int)t_relocatable];
  475.            nrbpage=grow_linear(i=nrbpage,tm->tm_growth_percent,
  476.                   tm->tm_min_grow, tm->tm_max_grow);
  477.            if (available_pages < 0)
  478.              nrbpage = i;
  479.            else {
  480.               rb_end +=  (PAGESIZE* (nrbpage -i));
  481.               rb_limit = rb_end - 2*RB_GETA;
  482.               if (page(rb_end) - page(heap_end) !=
  483.                   holepage + nrbpage)
  484.                 FEerror("bad rb_end");
  485.               alloc_page(-( nrbpage + holepage));
  486.               g = FALSE;
  487.               goto ONCE_MORE;
  488.             }
  489.         }
  490.         if (rb_limit > rb_end - 2*RB_GETA)
  491.             error("relocatable blocks exhausted");
  492.         rb_limit += RB_GETA;
  493.         vs_push(make_fixnum(nrbpage));
  494.         CEerror("Relocatable blocks exhausted.~%\
  495. Currently, ~D pages are allocated.~%\
  496. Use ALLOCATE-RELOCATABLE-PAGES to expand the space.",
  497.             "Continues execution.", 1, vs_head);
  498.         vs_pop;
  499.         g = FALSE;
  500.         goto ONCE_MORE;
  501.     }
  502.     p = rb_pointer;
  503.     rb_pointer += n;
  504.     return(p);
  505. }
  506.  
  507. init_tm(t, name, elsize, nelts,sgc)
  508. enum type t;
  509. char name[];
  510. int elsize, nelts;
  511. {
  512.     int i, j;
  513.     int maxpage;
  514.     /* round up to next number of pages */
  515.     maxpage = (((nelts * elsize) + PAGESIZE -1)/PAGESIZE);
  516.     tm_table[(int)t].tm_name = name;
  517.     for (j = -1, i = 0;  i < (int)t_end;  i++)
  518.         if (tm_table[i].tm_size != 0 &&
  519.             tm_table[i].tm_size >= elsize &&
  520.             (j < 0 || tm_table[j].tm_size > tm_table[i].tm_size))
  521.             j = i;
  522.     if (j >= 0) {
  523.         tm_table[(int)t].tm_type = (enum type)j;
  524.         tm_table[j].tm_maxpage += maxpage;
  525. #ifdef SGC        
  526.         tm_table[j].tm_sgc += sgc;
  527. #endif
  528.         return;
  529.     }
  530.     tm_table[(int)t].tm_type = t;
  531.     tm_table[(int)t].tm_size = round_up(elsize);
  532.     tm_table[(int)t].tm_nppage = PAGESIZE/round_up(elsize);
  533.     tm_table[(int)t].tm_free = OBJNULL;
  534.     tm_table[(int)t].tm_nfree = 0;
  535.     tm_table[(int)t].tm_nused = 0;
  536.     tm_table[(int)t].tm_npage = 0;
  537.     tm_table[(int)t].tm_maxpage = maxpage;
  538.     tm_table[(int)t].tm_gbccount = 0;
  539. #ifdef SGC    
  540.     tm_table[(int)t].tm_sgc = sgc;
  541.     tm_table[(int)t].tm_sgc_max = 3000;
  542.     tm_table[(int)t].tm_sgc_minfree = (int)
  543.       (0.4 * tm_table[(int)t].tm_nppage);
  544. #endif
  545.  
  546. }
  547.  
  548. set_maxpage()
  549. {
  550.   /* This is run in init.  Various initializations including getting
  551.      maxpage are here */ 
  552. #ifdef SGC
  553.   page_multiple=getpagesize()/PAGESIZE;
  554.   if (page_multiple==0) error("PAGESIZE must be factor of getpagesize()");
  555.   if (sgc_enabled)
  556.     {memory_protect(1);}
  557.   if (~(-MAXPAGE) != MAXPAGE-1) error("MAXPAGE must be power of 2");
  558.   if (core_end)
  559.      bzero(&sgc_type_map[ page(core_end)],MAXPAGE- page(core_end));
  560. #else
  561.   page_multiple=1;
  562. #endif
  563.   
  564. SET_REAL_MAXPAGE;
  565.  
  566.       }
  567.  
  568.  
  569.  
  570.  
  571.  
  572. init_alloc()
  573. {
  574.     int i, j;
  575.     struct typemanager *tm;
  576.     char *p, *q;
  577.     enum type t;
  578.     int c;
  579.     static initialized;
  580.     if (initialized) return;
  581.     initialized=1;
  582.     
  583.  
  584. #ifndef DONT_NEED_MALLOC    
  585.  
  586.     {
  587.         extern object malloc_list;
  588.         malloc_list = Cnil;
  589.         enter_mark_origin(&malloc_list);
  590.     }
  591. #endif    
  592.  
  593.     holepage = INIT_HOLEPAGE;
  594.     new_holepage = HOLEPAGE;
  595.     nrbpage = INIT_NRBPAGE;
  596.  
  597.     set_maxpage();
  598.  
  599.  
  600.     INIT_ALLOC;
  601.     
  602.  
  603.     alloc_page(-(holepage + nrbpage));
  604.     rb_start = rb_pointer = heap_end + PAGESIZE*holepage;
  605.     rb_end = rb_start + PAGESIZE*nrbpage;
  606.     rb_limit = rb_end - 2*RB_GETA;
  607. #ifdef SGC    
  608.     tm_table[(int)t_relocatable].tm_sgc = 50;
  609. #endif
  610.     
  611.     for (i = 0;  i < MAXPAGE;  i++)
  612.         type_map[i] = (char)t_other;
  613.  
  614.     init_tm(t_fixnum, "NFIXNUM",
  615.         sizeof(struct fixnum_struct), 8192,20);
  616.     init_tm(t_cons, ".CONS", sizeof(struct cons), 65536 ,50 );
  617.     init_tm(t_structure, "SSTRUCTURE", sizeof(struct structure), 5461,0 );
  618.     init_tm(t_cfun, "fCFUN", sizeof(struct cfun), 4096,0  );
  619.     init_tm(t_sfun, "gSFUN", sizeof(struct sfun),409,0 );
  620.     init_tm(t_string, "\"STRING", sizeof(struct string), 5461,1  );
  621.     init_tm(t_array, "aARRAY", sizeof(struct array), 4681,1 );
  622.     init_tm(t_symbol, "|SYMBOL", sizeof(struct symbol), 3640,1 );
  623.     init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum), 2730,0 );
  624.     init_tm(t_ratio, "RRATIONAL", sizeof(struct ratio), 170,0 );
  625.     init_tm(t_shortfloat, "FSHORT-FLOAT",
  626.         sizeof(struct shortfloat_struct), 256 ,0);
  627.     init_tm(t_longfloat, "LLONG-FLOAT",
  628.         sizeof(struct longfloat_struct), 170 ,0);
  629.     init_tm(t_complex, "CCOMPLEX", sizeof(struct complex), 170 ,0);
  630.     init_tm(t_character,"#CHARACTER",sizeof(struct character), 256 ,0);
  631.     init_tm(t_package, ":PACKAGE", sizeof(struct package), 2*PAGESIZE / sizeof(struct package),0);
  632.     init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct hashtable), 78,0 );
  633.     init_tm(t_vector, "vVECTOR", sizeof(struct vector), 146 ,0);
  634.     init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct bitvector), 73 ,0);
  635.     init_tm(t_stream, "sSTREAM", sizeof(struct stream), 78 ,0);
  636.     init_tm(t_random, "$RANDOM-STATE", sizeof(struct random), 256 ,0);
  637.     init_tm(t_readtable, "rREADTABLE", sizeof(struct readtable), 256 ,0);
  638.     init_tm(t_pathname, "pPATHNAME", sizeof(struct pathname), 73 ,0);
  639.     init_tm(t_cclosure, "cCCLOSURE", sizeof(struct cclosure), 85 ,0);
  640.     init_tm(t_vfun, "VVFUN", sizeof(struct vfun), 102 ,0);
  641.     init_tm(t_gfun, "gGFUN", sizeof(struct sfun), 0 ,0);
  642.     init_tm(t_cfdata, "cCFDATA", sizeof(struct cfdata), 102 ,0);
  643.     init_tm(t_spice, "!SPICE", sizeof(struct spice), 4096 ,0);
  644.     init_tm(t_fat_string, "FFAT-STRING", sizeof(struct fat_string), 102
  645.         ,0);
  646.     init_tm(t_relocatable, "%RELOCATABLE-BLOCKS", 1000,0,20);
  647.     init_tm(t_contiguous, "_CONTIGUOUS-BLOCKS", 1001,0,20);
  648.  
  649.  
  650.     ncb = 0;
  651.     ncbpage = 0;
  652.     maxcbpage = 512;
  653.     
  654. }
  655.  
  656.  
  657. cant_get_a_type()
  658. {
  659.     FEerror("Can't get a type.", 0);
  660. }
  661.  
  662. siLallocate()
  663. {
  664.     struct typemanager *tm;
  665.     int c, i;
  666.     char *p, *pp;
  667.     object f, x;
  668.     int t;
  669.  
  670.     if (vs_top - vs_base < 2)
  671.         too_few_arguments();
  672.     if (vs_top - vs_base > 3)
  673.       too_many_arguments();
  674.     t= t_from_type(vs_base[0]);
  675.     if (type_of(vs_base[1]) != t_fixnum ||
  676.         (i = fix(vs_base[1])) < 0)
  677.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[1]);
  678.     tm = tm_of(t);
  679.     if (tm->tm_npage > i) {i=tm->tm_npage;}
  680.     tm->tm_maxpage = i;
  681.     if (vs_top - vs_base == 3 && vs_base[2] != Cnil &&
  682.         tm->tm_maxpage > tm->tm_npage)
  683.       goto ALLOCATE;
  684.     vs_top = vs_base;
  685.     vs_push(Ct);
  686.     return;
  687.  
  688. ALLOCATE:
  689.     if (available_pages < tm->tm_maxpage - tm->tm_npage ||
  690.         (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) {
  691.     vs_push(make_simple_string(tm->tm_name+1));
  692.     FEerror("Can't allocate ~D pages for ~A.", 2, vs_base[1], vs_top[-1]);
  693.     }
  694.     for (;  tm->tm_npage < tm->tm_maxpage;  pp += PAGESIZE)
  695.       add_page_to_freelist(pp,tm);
  696.     vs_top = vs_base;
  697.     vs_push(Ct);
  698. }
  699.  
  700. t_from_type(type)
  701.      object type;
  702. {object typ= coerce_to_string(type);
  703.  object c = aref1(typ,0);
  704.  int i;
  705.  for (i= (int)t_start ; i < (int)t_contiguous ; i++)
  706.    {struct typemanager *tm = &tm_table[i];
  707.    if(tm->tm_name &&
  708.       0==strncmp((tm->tm_name)+1,typ->st.st_self,typ->st.st_fillp)
  709.       )
  710.      return i;}
  711.  FEerror("Unrecognized type");
  712. }
  713. /* When sgc is enabled the TYPE should have at least MIN pages of sgc type,
  714.    and at most MAX of them.   Each page should be FREE_PERCENT free
  715.    when the sgc is turned on.  FREE_PERCENT is an integer between 0 and 100. 
  716.    */
  717.    
  718. object
  719. siSallocate_sgc(type,min,max,free_percent)
  720.      object type;
  721.      int min,max,free_percent;
  722. {int m,t=t_from_type(type);
  723.  struct typemanager *tm;
  724.  object res;
  725.  tm=tm_of(t);
  726.   res= list(3,make_fixnum(tm->tm_sgc),
  727.        make_fixnum(tm->tm_sgc_max),
  728.        make_fixnum((100*tm->tm_sgc_minfree)/tm->tm_nppage));
  729.  
  730.  if(min<0 || max< min || min > 3000 || free_percent < 0 || free_percent > 100)
  731.     goto END;
  732.  tm->tm_sgc_max=max;
  733.  tm->tm_sgc=min;
  734.  tm->tm_sgc_minfree= (tm->tm_nppage *free_percent) /100;
  735.  END:
  736.  return res;
  737. }
  738.  
  739. /* Growth of TYPE will be by at least MIN pages and at most MAX pages.
  740.    It will try to grow PERCENT of the current pages.
  741.    */
  742. object
  743. siSallocate_growth(type,min,max,percent)
  744. int min,max,percent;
  745. object type;
  746. {int  t=t_from_type(type);
  747.  struct typemanager *tm=tm_of(t);
  748.  object res;
  749.  res= list(3,make_fixnum(tm->tm_min_grow),
  750.        make_fixnum(tm->tm_max_grow),
  751.        make_fixnum(tm->tm_growth_percent));
  752.  
  753.  if(min<0 || max< min || min > 3000 || percent < 0 || percent > 500)
  754.     goto END;
  755.  tm->tm_max_grow=max;
  756.  tm->tm_min_grow=min;
  757.  tm->tm_growth_percent= percent;
  758.  END:
  759.  return res;
  760. }
  761.  
  762.   
  763.  
  764. siLallocated_pages()
  765. {
  766.     struct typemanager *tm;
  767.     int c;
  768.  
  769.     check_arg(1);
  770.     {int t=t_from_type(vs_base[0]);
  771.      vs_base[0]=make_fixnum(tm_of(t)->tm_npage);}
  772.       }
  773.  
  774.  
  775. siLmaxpage()
  776. {
  777.     struct typemanager *tm;
  778.     int c;
  779.  
  780.     check_arg(1);
  781.     {int t=t_from_type(vs_base[0]);
  782.      vs_base[0]=make_fixnum(tm_of(t)->tm_npage);}
  783.       }
  784.  
  785.  
  786. siLalloc_contpage()
  787. {
  788.     int i, m;
  789.     char *p;
  790.  
  791.     if (vs_top - vs_base < 1)
  792.         too_few_arguments();
  793.     if (vs_top - vs_base > 2)
  794.         too_many_arguments();
  795.     if (type_of(vs_base[0]) != t_fixnum ||
  796.         (i = fix(vs_base[0])) < 0)
  797.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[0]);
  798.     if (ncbpage > i)
  799.       { printf("Allocate contiguous %d: %d already there pages",i,ncbpage);
  800.         i=ncbpage;}
  801.     maxcbpage = i;
  802.     if (vs_top - vs_base < 2 || vs_base[1] == Cnil) {
  803.         vs_top = vs_base;
  804.         vs_push(Ct);
  805.         return;
  806.     }
  807.     m = maxcbpage - ncbpage;
  808.     if (available_pages < m || (p = alloc_page(m)) == NULL)
  809.         FEerror("Can't allocate ~D pages for contiguous blocks.",
  810.             1, vs_base[0]);
  811.     for (i = 0;  i < m;  i++)
  812.         type_map[page(p + PAGESIZE*i)] = (char)t_contiguous;
  813.     ncbpage += m;
  814.     insert_contblock(p, PAGESIZE*m);
  815.     vs_top = vs_base;
  816.     vs_push(Ct);
  817. }
  818.  
  819. siLncbpage()
  820. {
  821.     check_arg(0);
  822.     vs_push(make_fixnum(ncbpage));
  823. }
  824.  
  825. siLmaxcbpage()
  826. {
  827.     check_arg(0);
  828.     vs_push(make_fixnum(maxcbpage));
  829. }
  830.  
  831. siLalloc_relpage()
  832. {
  833.     int i;
  834.     char *p;
  835.  
  836.     if (vs_top - vs_base < 1)
  837.         too_few_arguments();
  838.     if (vs_top - vs_base > 2)
  839.         too_many_arguments();
  840.     if (type_of(vs_base[0]) != t_fixnum ||
  841.         (i = fix(vs_base[0])) < 0)
  842.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[0]);
  843.     if (nrbpage > i && rb_pointer >= rb_start + PAGESIZE*i - 2*RB_GETA
  844.      || 2*i > real_maxpage-page(heap_end)-new_holepage-real_maxpage/32)
  845.         FEerror("Can't set the limit for relocatable blocks to ~D.",
  846.             1, vs_base[0]);
  847.     rb_end += (i-nrbpage)*PAGESIZE;
  848.     nrbpage = i;
  849.     rb_limit = rb_end - 2*RB_GETA;
  850.     alloc_page(-(holepage + nrbpage));
  851.     vs_top = vs_base;
  852.     vs_push(Ct);
  853. }
  854.  
  855. siLnrbpage()
  856. {
  857.     check_arg(0);
  858.     vs_push(make_fixnum(nrbpage));
  859. }
  860.  
  861. siLget_hole_size()
  862. {
  863.     check_arg(0);
  864.     vs_push(make_fixnum(new_holepage));
  865. }
  866.  
  867. siLset_hole_size()
  868. {
  869.     int i;
  870.  
  871.     check_arg(1);
  872.     i = fixint(vs_base[0]);
  873.     if (i < 1 ||
  874.         i > real_maxpage - page(heap_end) - 2*nrbpage - real_maxpage/32)
  875.         FEerror("Illegal value for the hole size.", 0);
  876.     new_holepage = i;
  877. }
  878.  
  879. init_alloc_function()
  880. {
  881.     make_si_function("ALLOCATE", siLallocate);
  882.     make_si_function("ALLOCATED-PAGES", siLallocated_pages);
  883.     make_si_function("MAXIMUM-ALLOCATABLE-PAGES", siLmaxpage);
  884.     make_si_function("ALLOCATE-CONTIGUOUS-PAGES", siLalloc_contpage);
  885.     make_si_function("ALLOCATED-CONTIGUOUS-PAGES", siLncbpage);
  886.     make_si_function("MAXIMUM-CONTIGUOUS-PAGES", siLmaxcbpage);
  887.     make_si_function("ALLOCATE-RELOCATABLE-PAGES", siLalloc_relpage);
  888.     make_si_function("ALLOCATED-RELOCATABLE-PAGES", siLnrbpage);
  889.     make_si_function("GET-HOLE-SIZE", siLget_hole_size);
  890.     make_si_function("SET-HOLE-SIZE", siLset_hole_size);
  891.     make_si_sfun("ALLOCATE-SGC",siSallocate_sgc,
  892.              4 | ARGTYPE(0,f_object) | ARGTYPE(1,f_fixnum) |
  893.              ARGTYPE(2,f_fixnum) | ARGTYPE(3,f_fixnum)
  894.              | RESTYPE(f_object));
  895.  
  896.  
  897.     make_si_sfun("ALLOCATE-GROWTH",siSallocate_growth,
  898.              4 | ARGTYPE(0,f_object) | ARGTYPE(1,f_fixnum) |
  899.              ARGTYPE(2,f_fixnum) | ARGTYPE(3,f_fixnum)
  900.              | RESTYPE(f_object));
  901.     Vignore_maximum_pages
  902.     = make_special("*IGNORE-MAXIMUM-PAGES*", Ct);
  903.  
  904. }
  905.  
  906. object malloc_list;
  907.  
  908. #ifndef DONT_NEED_MALLOC
  909.  
  910. /*
  911.     UNIX malloc simulator.
  912.  
  913.     Used by
  914.         getwd, popen, etc.
  915. */
  916.  
  917.  
  918.  
  919. /*  If this is defined, substitute the fast gnu malloc for the slower
  920.     version below.   If you have many calls to malloc this is worth
  921.     your while.   I have only tested it slightly under 4.3Bsd.   There
  922.     the difference in a test run with 120K mallocs and frees,
  923.     was 29 seconds to 1.9 seconds */
  924.     
  925. #ifdef GNU_MALLOC
  926. #include "malloc.c"
  927. #else
  928.  
  929. char *
  930. malloc(size)
  931. int size;
  932. {
  933.     object x;
  934.  
  935.     if (GBC_enable==0 && initflag ==0)
  936.       { init_alloc();}
  937.       
  938.  
  939.     x = alloc_simple_string(size);
  940.  
  941.     x->st.st_self = alloc_contblock(size);
  942. #ifdef SGC
  943.     perm_writable(x->st.st_self,size);
  944. #endif
  945.     malloc_list = make_cons(x, malloc_list);
  946.  
  947.     return(x->st.st_self);
  948. }
  949.  
  950.  
  951. void
  952. free(ptr)
  953. #ifndef NO_VOID_STAR
  954. void *
  955. #else
  956. char *
  957. #endif  
  958.   ptr;
  959. {
  960.     object *p;
  961.  
  962.     if (ptr == 0)
  963.       return;
  964.     for (p = &malloc_list; *p && !endp(*p);  p = &((*p)->c.c_cdr))
  965.         if ((*p)->c.c_car->st.st_self == ptr) {
  966.             insert_contblock((*p)->c.c_car->st.st_self,
  967.                      (*p)->c.c_car->st.st_dim);
  968.             (*p)->c.c_car->st.st_self = NULL;
  969.             *p = (*p)->c.c_cdr;
  970.             return ;
  971.         }
  972. #ifdef NOFREE_ERR
  973.     return ;
  974. #else    
  975.     FEerror("free(3) error.",0);
  976.     return;
  977. #endif    
  978. }
  979.  
  980. char *
  981. realloc(ptr, size)
  982. char *ptr;
  983. int size;
  984. {
  985.     object x;
  986.     int i, j;
  987.  
  988.     if(ptr == NULL) return malloc(size);
  989.     for (x = malloc_list;  !endp(x);  x = x->c.c_cdr)
  990.         if (x->c.c_car->st.st_self == ptr) {
  991.             x = x->c.c_car;
  992.             if (x->st.st_dim >= size) {
  993.                 x->st.st_fillp = size;
  994.                 return(ptr);
  995.             } else {
  996.                 j = x->st.st_dim;
  997.                 x->st.st_self = alloc_contblock(size);
  998.                 x->st.st_fillp = x->st.st_dim = size;
  999.                 for (i = 0;  i < size;  i++)
  1000.                     x->st.st_self[i] = ptr[i];
  1001.                 insert_contblock(ptr, j);
  1002.                 return(x->st.st_self);
  1003.             }
  1004.         }
  1005.     FEerror("realloc(3) error.", 0);
  1006. }
  1007.  
  1008. #endif /* gnumalloc */
  1009. char *
  1010. calloc(nelem, elsize)
  1011. int nelem, elsize;
  1012. {
  1013.     char *ptr;
  1014.     int i;
  1015.  
  1016.     ptr = malloc(i = nelem*elsize);
  1017.     while (--i >= 0)
  1018.         ptr[i] = 0;
  1019.     return(ptr);
  1020. }
  1021.  
  1022. cfree(ptr)
  1023. char *ptr;
  1024. {
  1025.     free(ptr);
  1026.  
  1027. }
  1028.  
  1029. #endif
  1030.  
  1031.  
  1032. #ifndef GNUMALLOC
  1033. char *
  1034. memalign(align,size)
  1035.      int align,size;
  1036. { object x = alloc_simple_string(size);
  1037.   x->st.st_self = ALLOC_ALIGNED(alloc_contblock,size,align);
  1038.   malloc_list = make_cons(x, malloc_list);
  1039.   return x->st.st_self;
  1040. }
  1041. #ifdef WANT_VALLOC
  1042. char *
  1043. valloc(size)
  1044. int size;     
  1045. { return memalign(getpagesize(),size);}
  1046. #endif
  1047.  
  1048. #endif
  1049.