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 / gbc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  27.2 KB  |  1,317 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.     GBC.c
  24.     IMPLEMENTATION-DEPENDENT
  25. */
  26.  
  27. #define    DEBUG
  28.  
  29. #define IN_GBC
  30. #include "include.h"
  31. #include "mp.h"
  32.  
  33. /* the following in line definitions seem to be twice as fast (at
  34. least on mc68020) as going to the assembly function calls in bitop.c so
  35. since this is more portable and faster lets use them --W. Schelter
  36. These assume that DBEGIN is divisible by 32, or else we should have
  37. #define Shamt(x) (((((int) x -DBEGIN) >> 2) & ~(~0 << 5)))
  38. */ 
  39.  
  40. #define Shamt(x) (((((int) x) >> 2) & ~(~0 << 5)))
  41. #define Madr(x) (mark_table+((((int) x) - ((int)DBEGIN)) >> (7)))
  42. #define get_mark_bit(x) (*(Madr(x)) >> Shamt(x) & 1)
  43. #define set_mark_bit(x) ((*(Madr(x))) |= (1 << Shamt(x)))
  44.  
  45. #ifdef KCLOVM
  46. void mark_all_stacks();
  47. bool ovm_process_created; 
  48. #endif
  49.  
  50.  
  51. bool saving_system;
  52. static int gc_time = -1;
  53. static int gc_start = 0;
  54. int runtime();
  55. int sgc_enabled=0;
  56. int  first_protectable_page =0;
  57.  
  58.  
  59. #define    round_up(n)    (((n) + 03) & ~03)
  60.  
  61. char *copy_relblock();
  62.  
  63. #include "page.h"
  64.  
  65.  
  66. #ifdef MV
  67.  
  68.  
  69. #endif
  70.  
  71.  
  72. int real_maxpage;
  73. int new_holepage;
  74.  
  75. #define    available_pages    \
  76.     (real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
  77.  
  78. struct apage {
  79.     char apage_self[PAGESIZE];
  80. };
  81.  
  82.  
  83. #define    inheap(pp)    ((char *)(pp) < heap_end)
  84.  
  85. int maxpage;
  86.  
  87. object siVnotify_gbc;
  88.  
  89. #ifdef DEBUG
  90. bool debug;
  91. object siVgbc_message;
  92. #endif
  93.  
  94. #define    MARK_ORIGIN_MAX        300
  95. #define    MARK_ORIGIN_BLOCK_MAX    20
  96.  
  97. #ifdef AV
  98. /*
  99.     See bitop.c.
  100. */
  101. #endif
  102. #ifdef MV
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117. #endif
  118.  
  119. #define    symbol_marked(x)    ((x)->d.m)
  120.  
  121. object *mark_origin[MARK_ORIGIN_MAX];
  122. int mark_origin_max;
  123.  
  124. struct {
  125.     object    *mob_addr;    /*  mark origin block address  */
  126.     int    mob_size;    /*  mark origin block size  */
  127. } mark_origin_block[MARK_ORIGIN_BLOCK_MAX];
  128. int mark_origin_block_max;
  129.  
  130. int *mark_table;
  131.  
  132. enum type what_to_collect;
  133.  
  134.  
  135.  
  136. enter_mark_origin(p)
  137. object *p;
  138. {
  139.     if (mark_origin_max >= MARK_ORIGIN_MAX)
  140.         error("too many mark origins");
  141. #ifdef SGC
  142.     sgc_type_map[page(p)] |= SGC_PERM_WRITABLE ;
  143. #endif    
  144.     mark_origin[mark_origin_max++] = p;
  145. }
  146.  
  147. enter_mark_origin_block(p, n)
  148. object *p;
  149. int n;
  150. {
  151.     if (mark_origin_block_max >= MARK_ORIGIN_BLOCK_MAX)
  152.         error("too many mark origin blocks");
  153.     mark_origin_block[mark_origin_block_max].mob_addr = p;
  154.     mark_origin_block[mark_origin_block_max++].mob_size = n;
  155. }
  156.  
  157. mark_cons(x)
  158. object x;
  159. {
  160.   cs_check(x);
  161.  
  162.     /*  x is already marked.  */
  163.  
  164. BEGIN:  
  165.     if (x->c.c_car == OBJNULL) goto MARK_CDR;
  166.     if (type_of(x->c.c_car) == t_cons) {
  167.         if (x->c.c_car->c.m)
  168.             ;
  169.         else {
  170.             x->c.c_car->c.m = TRUE;
  171.             mark_cons(x->c.c_car);
  172.         }
  173.     } else
  174.         mark_object(x->c.c_car);
  175. MARK_CDR:  
  176.     x = x->c.c_cdr;
  177.     if (x == OBJNULL)
  178.         return;
  179.     if (type_of(x) == t_cons) {
  180.         if (x->c.m)
  181.             return;
  182.         x->c.m = TRUE;
  183.         goto BEGIN;
  184.     }
  185.     if (x == Cnil)
  186.         return;
  187.     mark_object(x);
  188. }
  189.  
  190. /* Whenever two arrays are linked together by displacement,
  191.    if one is live, the other will be made live */
  192. #define mark_displaced_field(ar) mark_object(ar->a.a_displaced)
  193.  
  194. mark_object(x)
  195. object x;
  196. {
  197.     int i, j;
  198.     object *p;
  199.     char *cp;
  200.     object y;
  201.  
  202.     cs_check(x);
  203. BEGIN:
  204.     if (x == OBJNULL)
  205.         return;
  206.     if (x->d.m)
  207.         return;
  208.     x->d.m = TRUE;
  209.     switch (type_of(x)) {
  210.     case t_fixnum:
  211.         break;
  212.  
  213.     case t_ratio:
  214.         mark_object(x->rat.rat_num);
  215.         x = x->rat.rat_den;
  216.         goto BEGIN;
  217.  
  218.     case t_shortfloat:
  219.         break;
  220.  
  221.     case t_longfloat:
  222.         break;
  223.  
  224.     case t_complex:
  225.         mark_object(x->cmp.cmp_imag);
  226.         x = x->cmp.cmp_real;
  227.         goto BEGIN;
  228.  
  229.     case t_character:
  230.         break;
  231.  
  232.     case t_symbol:
  233.         mark_object(x->s.s_plist);
  234.         mark_object(x->s.s_gfdef);
  235.         mark_object(x->s.s_dbind);
  236.         if (x->s.s_self == NULL)
  237.             break;
  238.         if ((int)what_to_collect >= (int)t_contiguous) {
  239.             if (inheap(x->s.s_self)) {
  240.                 if (what_to_collect == t_contiguous)
  241.                     mark_contblock(x->s.s_self,
  242.                                x->s.s_fillp);
  243.             } else
  244.                 x->s.s_self =
  245.                 copy_relblock(x->s.s_self, x->s.s_fillp);
  246.         }
  247.         break;
  248.  
  249.     case t_package:
  250.         mark_object(x->p.p_name);
  251.         mark_object(x->p.p_nicknames);
  252.         mark_object(x->p.p_shadowings);
  253.         mark_object(x->p.p_uselist);
  254.         mark_object(x->p.p_usedbylist);
  255.         if (what_to_collect != t_contiguous)
  256.             break;
  257.         if (x->p.p_internal != NULL)
  258.             mark_contblock((char *)(x->p.p_internal),
  259.                        x->p.p_internal_size*sizeof(object));
  260.         if (x->p.p_external != NULL)
  261.             mark_contblock((char *)(x->p.p_external),
  262.                        x->p.p_external_size*sizeof(object));
  263.         break;
  264.  
  265.     case t_cons:
  266. /*
  267.         mark_object(x->c.c_car);
  268.         x = x->c.c_cdr;
  269.         goto BEGIN;
  270. */
  271.         mark_cons(x);
  272.         break;
  273.  
  274.     case t_hashtable:
  275.         mark_object(x->ht.ht_rhsize);
  276.         mark_object(x->ht.ht_rhthresh);
  277.         if (x->ht.ht_self == NULL)
  278.             break;
  279.         for (i = 0, j = x->ht.ht_size;  i < j;  i++) {
  280.             mark_object(x->ht.ht_self[i].hte_key);
  281.             mark_object(x->ht.ht_self[i].hte_value);
  282.         }
  283.         if ((short)what_to_collect >= (short)t_contiguous) {
  284.             if (inheap(x->ht.ht_self)) {
  285.                 if (what_to_collect == t_contiguous)
  286.                     mark_contblock((char *)(x->ht.ht_self),
  287.                                j * sizeof(struct htent));
  288.             } else
  289.                 x->ht.ht_self = (struct htent *)
  290.                 copy_relblock((char *)(x->ht.ht_self),
  291.                           j * sizeof(struct htent));
  292.         }
  293.         break;
  294.  
  295.     case t_array:
  296.         if ((x->a.a_displaced) != Cnil)
  297.           mark_displaced_field(x);
  298.         if ((int)what_to_collect >= (int)t_contiguous &&
  299.             x->a.a_dims != NULL) {
  300.             if (inheap(x->a.a_dims)) {
  301.                 if (what_to_collect == t_contiguous)
  302.                     mark_contblock((char *)(x->a.a_dims),
  303.                                sizeof(int)*x->a.a_rank);
  304.             } else
  305.                 x->a.a_dims = (int *)
  306.                 copy_relblock((char *)(x->a.a_dims),
  307.                           sizeof(int)*x->a.a_rank);
  308.         }
  309.         if ((enum aelttype)x->a.a_elttype == aet_ch)
  310.             goto CASE_STRING;
  311.         if ((enum aelttype)x->a.a_elttype == aet_bit)
  312.             goto CASE_BITVECTOR;
  313.         if ((enum aelttype)x->a.a_elttype == aet_object)
  314.             goto CASE_GENERAL;
  315.  
  316.     CASE_SPECIAL:
  317.         cp = (char *)(x->fixa.fixa_self);
  318.         if (cp == NULL)
  319.             break;
  320.         /* set j to the size in char of the body of the array */
  321.         
  322.         switch((enum aelttype)x->a.a_elttype){
  323. #define  ROUND_RB_POINTERS_DOUBLE \
  324. {int tem =  ((long)rb_pointer1) & (sizeof(double)-1); \
  325.    if (tem) \
  326.      { rb_pointer +=  (sizeof(double) - tem); \
  327.        rb_pointer1 +=  (sizeof(double) - tem); \
  328.      }}
  329.         case aet_lf:
  330.           j= sizeof(longfloat)*x->lfa.lfa_dim;
  331.               if (((int)what_to_collect >= (int)t_contiguous) &&
  332.             !(inheap(cp))) ROUND_RB_POINTERS_DOUBLE;
  333.           break;
  334.         case aet_char:
  335.         case aet_uchar:
  336.           j=sizeof(char)*x->a.a_dim;
  337.           break;
  338.         case aet_short:
  339.         case aet_ushort:
  340.           j=sizeof(short)*x->a.a_dim;
  341.           break;
  342.         default:
  343.           j=sizeof(fixnum)*x->fixa.fixa_dim;}
  344.  
  345.         goto COPY;
  346.  
  347.     CASE_GENERAL:
  348.         p = x->a.a_self;
  349.         if (p == NULL
  350. #ifdef HAVE_ALLOCA
  351.                    || (char *)p >= core_end
  352. #endif  
  353.                    )
  354.             break;
  355.         if (x->a.a_displaced->c.c_car == Cnil)
  356.             for (i = 0, j = x->a.a_dim;  i < j;  i++)
  357.                 mark_object(p[i]);
  358.         cp = (char *)p;
  359.         j *= sizeof(object);
  360.     COPY:
  361.         if ((int)what_to_collect >= (int)t_contiguous) {
  362.             if (inheap(cp)) {
  363.                 if (what_to_collect == t_contiguous)
  364.                     mark_contblock(cp, j);
  365.             } else if (x->a.a_displaced == Cnil) {
  366. #ifdef HAVE_ALLOCA
  367.               if (cp <= core_end)  /* only if body of array not on C stack */
  368. #endif              
  369.                 x->a.a_self = (object *)copy_relblock(cp, j);}
  370.             else if (x->a.a_displaced->c.c_car == Cnil) {
  371.                 i = (int)(object *)copy_relblock(cp, j)
  372.                   - (int)(x->a.a_self);
  373.                 adjust_displaced(x, i);
  374.             }
  375.         }
  376.         break;
  377.  
  378.     case t_vector:
  379.         if ((x->v.v_displaced) != Cnil)
  380.           mark_displaced_field(x);
  381.         if ((enum aelttype)x->v.v_elttype == aet_object)
  382.             goto CASE_GENERAL;
  383.         else
  384.             goto CASE_SPECIAL;
  385.  
  386.         case t_bignum:
  387.         if ((int)what_to_collect >= (int)t_contiguous) {
  388.           j = x->big.big_length;
  389.           cp = (char *)(x->big.big_self);
  390.           if (cp == 0)
  391.             break;
  392.           if (j != lg(MP(x))  &&
  393.               /* we don't bother to zero this register,
  394.              and its contents may get over written */
  395.               ! (x == big_register_1 &&
  396.              (int)(cp) <= top &&
  397.              (int) cp >= bot))
  398.             printf("bad length 0x%x ",x);
  399.           j = j * sizeof(int);
  400.         
  401.           if (inheap(cp)) {
  402.             if (what_to_collect == t_contiguous)
  403.               mark_contblock(cp, j);
  404.           } else 
  405.             x->big.big_self = (long *) copy_relblock(cp, j);}
  406.         break;
  407.  
  408.     CASE_STRING:
  409.     case t_string:
  410.         if ((x->st.st_displaced) != Cnil)
  411.           mark_displaced_field(x);
  412.         j = x->st.st_dim;
  413.         cp = x->st.st_self;
  414.         if (cp == NULL)
  415.             break;
  416.     COPY_STRING:
  417.         if ((int)what_to_collect >= (int)t_contiguous) {
  418.             if (inheap(cp)) {
  419.                 if (what_to_collect == t_contiguous)
  420.                     mark_contblock(cp, j);
  421.             } else if (x->st.st_displaced == Cnil)
  422.                 x->st.st_self = copy_relblock(cp, j);
  423.             else if (x->st.st_displaced->c.c_car == Cnil) {
  424.                 i = copy_relblock(cp, j) - cp;
  425.                 adjust_displaced(x, i);
  426.             }
  427.         }
  428.         break;
  429.  
  430.     CASE_BITVECTOR:
  431.     case t_bitvector:
  432.         if ((x->bv.bv_displaced) != Cnil)
  433.           mark_displaced_field(x);
  434. /* We make bitvectors multiple of sizeof(int) in size allocated
  435.  Assume 8 = number of bits in char */
  436.  
  437. #define W_SIZE (8*sizeof(int))
  438.         j= sizeof(int) *
  439.            ((x->bv.bv_offset + x->bv.bv_dim + W_SIZE -1)/W_SIZE);
  440.         cp = x->bv.bv_self;
  441.         if (cp == NULL)
  442.             break;
  443.         goto COPY_STRING;
  444.  
  445.     case t_structure:
  446.         mark_object(x->str.str_def);
  447.         p = x->str.str_self;
  448.         if (p == NULL)
  449.             break;
  450.         {object def=x->str.str_def;
  451.          unsigned char * s_type = &SLOT_TYPE(def,0);
  452.          unsigned short *s_pos= & SLOT_POS(def,0);
  453.          for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
  454.            if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
  455.          if ((int)what_to_collect >= (int)t_contiguous) {
  456.              if (inheap(x->str.str_self)) {
  457.                if (what_to_collect == t_contiguous)
  458.              mark_contblock((char *)p,
  459.                     S_DATA(def)->size);
  460.  
  461.              } else
  462.                x->str.str_self = (object *)
  463.              copy_relblock((char *)p, S_DATA(def)->size);
  464.            }}
  465.         break;
  466.  
  467.     case t_stream:
  468.         switch (x->sm.sm_mode) {
  469.         case smm_input:
  470.         case smm_output:
  471.         case smm_io:
  472.         case smm_probe:
  473.             mark_object(x->sm.sm_object0);
  474.             mark_object(x->sm.sm_object1);
  475.             if (saving_system)
  476.               {FILE *fp = x->sm.sm_fp;
  477.                  if (fp != 0 && fp != stdin && fp !=stdout
  478.                  )
  479.                  {fclose(fp);
  480.                   x->sm.sm_fp=0;
  481.                 }}
  482.             else
  483.             if (what_to_collect == t_contiguous &&
  484.                 x->sm.sm_fp &&
  485.                 x->sm.sm_buffer)
  486.                 mark_contblock(x->sm.sm_buffer, BUFSIZ);
  487.             break;
  488.  
  489.         case smm_synonym:
  490.             mark_object(x->sm.sm_object0);
  491.             break;
  492.  
  493.         case smm_broadcast:
  494.         case smm_concatenated:
  495.             mark_object(x->sm.sm_object0);
  496.             break;
  497.  
  498.         case smm_two_way:
  499.         case smm_echo:
  500.             mark_object(x->sm.sm_object0);
  501.             mark_object(x->sm.sm_object1);
  502.             break;
  503.  
  504.         case smm_string_input:
  505.         case smm_string_output:
  506.             mark_object(x->sm.sm_object0);
  507.             break;
  508. #ifdef USER_DEFINED_STREAMS
  509.                case smm_user_defined:
  510.             mark_object(x->sm.sm_object0);
  511.             mark_object(x->sm.sm_object1);
  512.             break;
  513. #endif
  514.         default:
  515.             error("mark stream botch");
  516.         }
  517.         break;
  518.  
  519.     case t_random:
  520.         break;
  521.  
  522.     case t_readtable:
  523.         if (x->rt.rt_self == NULL)
  524.             break;
  525.         if (what_to_collect == t_contiguous)
  526.             mark_contblock((char *)(x->rt.rt_self),
  527.                        RTABSIZE*sizeof(struct rtent));
  528.         for (i = 0;  i < RTABSIZE;  i++) {
  529.             mark_object(x->rt.rt_self[i].rte_macro);
  530.             if (x->rt.rt_self[i].rte_dtab != NULL) {
  531. /**/
  532.     if (what_to_collect == t_contiguous)
  533.         mark_contblock((char *)(x->rt.rt_self[i].rte_dtab),
  534.                    RTABSIZE*sizeof(object));
  535.     for (j = 0;  j < RTABSIZE;  j++)
  536.         mark_object(x->rt.rt_self[i].rte_dtab[j]);
  537. /**/
  538.             }
  539.         }
  540.         break;
  541.  
  542.     case t_pathname:
  543.         mark_object(x->pn.pn_host);
  544.         mark_object(x->pn.pn_device);
  545.         mark_object(x->pn.pn_directory);
  546.         mark_object(x->pn.pn_name);
  547.         mark_object(x->pn.pn_type);
  548.         mark_object(x->pn.pn_version);
  549.         break;
  550.  
  551.     case t_cfun:
  552.         case t_sfun:
  553.         case t_vfun:
  554.     case t_gfun:    
  555.         mark_object(x->cf.cf_name);
  556.         mark_object(x->cf.cf_data);
  557.         break;
  558.         
  559.         case t_cfdata:
  560.  
  561.             if (x->cfd.cfd_self != NULL)
  562.           {int i=x->cfd.cfd_fillp;
  563.            while(i-- > 0)
  564.              mark_object(x->cfd.cfd_self[i]);}
  565.         if (x->cfd.cfd_start == NULL)
  566.             break;
  567.         if (what_to_collect == t_contiguous) {
  568.             if (!MAYBE_DATA_P((x->cfd.cfd_start)) ||
  569.                 get_mark_bit((int *)(x->cfd.cfd_start)))
  570.                 break;
  571.             mark_contblock(x->cfd.cfd_start, x->cfd.cfd_size);}
  572.         break;
  573.     case t_cclosure:
  574.         mark_object(x->cc.cc_name);
  575.         mark_object(x->cc.cc_env);
  576.                 mark_object(x->cc.cc_data);
  577.         if (what_to_collect == t_contiguous) {
  578.           if (x->cc.cc_turbo != NULL)
  579.                      mark_contblock((char *)(x->cc.cc_turbo-1),
  580.                                    (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));
  581.         }
  582.         break;
  583.  
  584.     case t_spice:
  585.         break;
  586.         case t_fat_string:
  587.         mark_fat_string(x);
  588.         break;
  589.         case t_dclosure:
  590.                 break;
  591.     default:
  592. #ifdef DEBUG
  593.         if (debug)
  594.             printf("\ttype = %d\n", type_of(x));
  595. #endif
  596.         error("mark botch");
  597.     }
  598. }
  599.  
  600. static int *c_stack_where;
  601.  
  602. mark_stack_carefully(top,bottom,offset)
  603. int *bottom,*top;
  604. {int p,m,pageoffset;
  605.  object x;
  606.  struct typemanager *tm;
  607.  register int *j;
  608.  
  609.  /* if either of these happens we are marking the C stack
  610.     and need to use a local */
  611.  
  612.  if (top==0) top = c_stack_where;
  613.  if (bottom==0) bottom= c_stack_where;
  614.  
  615.  /* On machines which align local pointers on multiple of 2 rather
  616.     than 4 we need to mark twice
  617.    */
  618.  
  619.  if (offset) {mark_stack_carefully(bottom,(((char *) top) +offset),0);}
  620.  for (j=top ; j >= bottom ; j--)
  621.    {if (VALID_DATA_ADDRESS_P(*j)
  622.     && type_map[(p=page(*j))]< (char)t_end)
  623.       {pageoffset=((char *)*j - pagetochar(p));
  624.        tm=tm_of((enum type) type_map[p]);
  625.        x= (object)
  626.      ((char *)(*j) -
  627.       ((pageoffset=((char *)*j - pagetochar(p))) %
  628.        tm->tm_size));
  629.        if ((pageoffset <  (tm->tm_size * tm->tm_nppage))
  630.        && (m=x->d.m) != FREE)
  631.        {if (m==TRUE) continue;
  632.       if (m!=0)
  633.         {fprintf(stdout,
  634.              "**bad value %d of d.m in gbc page %d skipping mark**"
  635.              ,m,p);fflush(stdout);
  636.          continue;
  637.        };
  638.       mark_object(x);}}}}
  639.  
  640.  
  641. mark_phase()
  642. {
  643.     STATIC object *p;
  644.     STATIC int i, j, k, n;
  645.     STATIC struct package *pp;
  646.     STATIC object s, l, *lp;
  647.     STATIC bds_ptr bdp;
  648.     STATIC frame_ptr frp;
  649.     STATIC ihs_ptr ihsp;
  650.     STATIC char *cp;
  651.  
  652.     mark_object(Cnil);
  653.     mark_object(Ct);
  654.  
  655.     mark_stack_carefully(vs_top-1,vs_org,0);
  656.     clear_stack(vs_top,vs_limit);
  657.     mark_stack_carefully(MVloc,MVloc+(sizeof(MVloc)/sizeof(object)),0);
  658.     /* 
  659.     for (p = vs_org;  p < vs_top;  p++) {
  660.       if (p && (inheap(*p)))
  661.         mark_object(*p);
  662.     }
  663.     */
  664. #ifdef DEBUG
  665.     if (debug) {
  666.         printf("value stack marked\n");
  667.         fflush(stdout);
  668.     }
  669. #endif
  670.  
  671.     for (bdp = bds_org;  bdp<=bds_top;  bdp++) {
  672.          mark_object(bdp->bds_sym);
  673.         mark_object(bdp->bds_val);
  674.     }
  675.  
  676.     for (frp = frs_org;  frp <= frs_top;  frp++)
  677.         mark_object(frp->frs_val);
  678.  
  679.     for (ihsp = ihs_org;  ihsp <= ihs_top;  ihsp++)
  680.         mark_object(ihsp->ihs_function);
  681.  
  682.     for (i = 0;  i < mark_origin_max;  i++)
  683.         mark_object(*mark_origin[i]);
  684.     for (i = 0;  i < mark_origin_block_max;  i++)
  685.         for (j = 0;  j < mark_origin_block[i].mob_size;  j++)
  686.             mark_object(mark_origin_block[i].mob_addr[j]);
  687.  
  688.     for (pp = pack_pointer;  pp != NULL;  pp = pp->p_link)
  689.         mark_object(pp);
  690. #ifdef KCLOVM
  691.     if (ovm_process_created)
  692.       mark_all_stacks();
  693. #endif
  694.  
  695. #ifdef DEBUG
  696.     if (debug) {
  697.         printf("symbol navigation\n");
  698.         fflush(stdout);
  699.     }
  700. #endif
  701.  
  702. /*
  703.     if (what_to_collect != t_symbol &&
  704.         (int)what_to_collect < (int)t_contiguous) {
  705. */
  706.  
  707.     {int size;
  708.      
  709.      for (pp = pack_pointer;  pp != NULL;  pp = pp->p_link) {
  710.                     size = pp->p_internal_size;
  711.             if (pp->p_internal != NULL)
  712.                 for (i = 0;  i < size;  i++)
  713.                     mark_object(pp->p_internal[i]);
  714.             size = pp->p_external_size;
  715.             if (pp->p_external != NULL)
  716.                 for (i = 0;  i < size;  i++)
  717.                     mark_object(pp->p_external[i]);
  718.         }}
  719.  
  720.    /* mark the c stack */
  721. #ifndef N_RECURSION_REQD
  722. #define N_RECURSION_REQD 2
  723. #endif
  724.      mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully);
  725.   
  726. }
  727.  
  728. mark_c_stack(env1,n,fn)
  729.      jmp_buf *env1;
  730.      int n;
  731.      int (*fn)();
  732. {jmp_buf env;
  733.  int where;
  734.  if (n== N_RECURSION_REQD)
  735.    { c_stack_where = (int *) (void *) &env;}
  736.  if (n > 0 )
  737.    {  setjmp(env);
  738.       mark_c_stack(env,n - 1,fn);}
  739.  else
  740.    {
  741.      
  742.      /* If the locals of type object in a C function could be
  743.     aligned other than on multiples of sizeof (char *)
  744.     then define this.  At the moment 2 is the only other
  745.     legitimate value besides 0 */
  746.      
  747. #ifndef C_GC_OFFSET
  748. #define C_GC_OFFSET 0
  749. #endif
  750.      if (&where > cs_org)
  751.       (*fn)(0,cs_org,C_GC_OFFSET);
  752.      else
  753.        (*fn)(cs_org,0,C_GC_OFFSET);}
  754.  
  755. }
  756.  
  757.  
  758.  
  759.  
  760. sweep_phase()
  761. {
  762.     STATIC int i, j, k;
  763.     STATIC object x;
  764.     STATIC char *p;
  765.     STATIC int *ip;
  766.     STATIC struct typemanager *tm;
  767.     STATIC object f;
  768.  
  769.     Cnil->s.m = FALSE;
  770.     Ct->s.m = FALSE;
  771.  
  772. #ifdef DEBUG
  773.     if (debug)
  774.         printf("type map\n");
  775. #endif
  776.     for (i = 0;  i < maxpage;  i++) {
  777.         if (type_map[i] == (int)t_contiguous) {
  778.             if (debug) {
  779.                 printf("-");
  780.             /*
  781.                 fflush(stdout);
  782.             */
  783.                 continue;
  784.             }
  785.         }
  786.         if (type_map[i] >= (int)t_end)
  787.             continue;
  788.  
  789.         tm = tm_of((enum type)type_map[i]);
  790.  
  791.     /*
  792.         general sweeper
  793.     */
  794.  
  795. #ifdef DEBUG
  796.         if (debug) {
  797.             printf("%c", tm->tm_name[0]);
  798.         /*
  799.             fflush(stdout);
  800.         */
  801.         }
  802. #endif
  803.         p = pagetochar(i);
  804.         f = tm->tm_free;
  805.         k = 0;
  806.         for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) {
  807.             x = (object)p;
  808.             if (x->d.m == FREE)
  809.                 continue;
  810.             else if (x->d.m) {
  811.                 x->d.m = FALSE;
  812.                 continue;
  813.             }
  814.             /*   Since we now mark forwards and backwards on displaced
  815.                  arrays, this is not necessary.
  816.             switch (x->d.t) {
  817.             case t_array:
  818.             case t_vector:
  819.             case t_string:
  820.             case t_bitvector:
  821.                 if (x->a.a_displaced->c.c_car != Cnil)
  822.                   {undisplace(x);
  823.                  }
  824.             }
  825.             */
  826.             ((struct freelist *)x)->f_link = f;
  827.             x->d.m = FREE;
  828.             f = x;
  829.             k++;
  830.         }
  831.         tm->tm_free = f;
  832.         tm->tm_nfree += k;
  833.  
  834.     NEXT_PAGE:
  835.         ;
  836.     }
  837. #ifdef DEBUG
  838.     if (debug) {
  839.         putchar('\n');
  840.         fflush(stdout);
  841.     }
  842. #endif
  843. }
  844.  
  845. contblock_sweep_phase()
  846. {
  847.     STATIC int i, j;
  848.     STATIC char *s, *e, *p, *q;
  849.     STATIC struct contblock *cbp;
  850.  
  851.     cb_pointer = NULL;
  852.     ncb = 0;
  853.     for (i = 0;  i < maxpage;) {
  854.         if (type_map[i] != (int)t_contiguous) {
  855.             i++;
  856.             continue;
  857.         }
  858.         for (j = i+1;
  859.              j < maxpage && type_map[j] == (int)t_contiguous;
  860.              j++)
  861.             ;    
  862.         s = pagetochar(i);
  863.         e = pagetochar(j);
  864.         for (p = s;  p < e;) {
  865.             if (get_mark_bit((int *)p)) {
  866.                 p += 4;
  867.                 continue;
  868.             }
  869.             q = p + 4;
  870.             while (q < e) {
  871.                 if (!get_mark_bit((int *)q)) {
  872.                     q += 4;
  873.                     continue;
  874.                 }
  875.                 break;
  876.             }
  877.             insert_contblock(p, q - p);
  878.             p = q + 4;
  879.         }
  880.         i = j + 1;
  881.     }
  882. #ifdef DEBUG
  883.     if (debug) {
  884.         for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link)
  885.             printf("%d-byte contblock\n", cbp->cb_size);
  886.         fflush(stdout);
  887.     }
  888. #endif
  889. }
  890.  
  891.  
  892. int (*GBC_enter_hook)() = NULL;
  893. int (*GBC_exit_hook)() = NULL;
  894. char *old_rb_start;
  895. GBC(t)
  896. enum type t;
  897. {
  898.     int i, j;
  899.     struct apage *pp, *qq;
  900.     int in_sgc = sgc_enabled;
  901.     int where ;
  902. #ifdef DEBUG
  903.     int tm;
  904. #endif
  905.     
  906.  
  907.  
  908.     if (GBC_enter_hook != NULL)
  909.         (*GBC_enter_hook)();
  910.  
  911.     if (!GBC_enable)
  912.              error("GBC is not enabled");
  913.     interrupt_enable = FALSE;
  914.  
  915.     if (saving_system)
  916.         {t = t_contiguous; gc_time = -1;
  917.          if(sgc_enabled) sgc_quit();
  918.  
  919.            }
  920.  
  921.  
  922. #ifdef DEBUG
  923.     debug = symbol_value(siVgbc_message) != Cnil;
  924. #endif
  925.  
  926.     what_to_collect = t;
  927.  
  928.     if (t == t_contiguous)
  929.         cbgbccount++;
  930.     else if (t == t_relocatable)
  931.         rbgbccount++;
  932.     else
  933.         tm_table[(int)t].tm_gbccount++;
  934.  
  935. #ifdef DEBUG
  936.     if (debug || (siVnotify_gbc->s.s_dbind != Cnil)) {
  937.  
  938.       if (gc_time < 0) gc_time=0;
  939.       printf("[%s for %d %s pages..",
  940.          (sgc_enabled ? "SGC" : "GC"),
  941.          (sgc_enabled ? sgc_count_type(t) : tm_of(t)->tm_npage),
  942.          (tm_table[(int)t].tm_name)+1);
  943. #ifdef SGC
  944.       if(sgc_enabled)
  945.         printf("(%d writable)..",sgc_count_writable(page(core_end)));
  946. #endif      
  947.       fflush(stdout);
  948.     }
  949. #endif
  950.         if (gc_time >=0) {gc_start=runtime();}
  951.  
  952.     maxpage = page(heap_end);
  953.  
  954.     if ((int)t >= (int)t_contiguous) {
  955.         j = maxpage*(PAGESIZE/(sizeof(int)*sizeof(int)*CHAR_SIZE)) ;
  956.         /*
  957.             (PAGESIZE / sizeof(int)) = x * (sizeof(int)*CHAR_SIZE)
  958.             eg if PAGESIZE = 2048  x=16
  959.             1 page = 512 long word
  960.             512 bit = 16 long word
  961.         */
  962.  
  963.         if (t == t_relocatable)
  964.             j = 0;
  965.            /* if in sgc we don't need more pages below hole
  966.           just more relocatable or cleaning it */
  967.         if (sgc_enabled ==0 && holepage < new_holepage)
  968.             holepage = new_holepage;
  969.  
  970.         i = rb_pointer - (sgc_enabled ? old_rb_start : rb_start);
  971.  
  972.         if (nrbpage > (real_maxpage-page(heap_end)
  973.                        -holepage-real_maxpage/32)/2) {
  974.             if (i > nrbpage*PAGESIZE)
  975.                 error("Can't allocate.  Good-bye!.");
  976.             else
  977.                 nrbpage =
  978.                 (real_maxpage-page(heap_end)
  979.                  -holepage-real_maxpage/32)/2;
  980.         }
  981.  
  982.         if (saving_system)
  983.             rb_start = heap_end;
  984.         else
  985.           if (sgc_enabled==0)
  986.             {rb_start = heap_end + PAGESIZE*holepage;}
  987.  
  988.         rb_end = heap_end + (holepage + nrbpage) *PAGESIZE;
  989.  
  990.         if (rb_start < rb_pointer)
  991.             rb_start1 = (char *)
  992.             ((int)(rb_pointer + PAGESIZE-1) & -PAGESIZE);
  993.         else
  994.             rb_start1 = rb_start;
  995.  
  996.         rb_pointer = rb_start;
  997.         rb_pointer1 = rb_start1;
  998.  
  999.         mark_table = (int *)(rb_start1 + i);
  1000.  
  1001.         if (rb_end < (char *)&mark_table[j])
  1002.             i = (char *)&mark_table[j] - heap_end;
  1003.         else
  1004.             i = rb_end - heap_end;
  1005.         alloc_page(-(i + PAGESIZE - 1)/PAGESIZE);
  1006.  
  1007.         for (i = 0;  i < j; i++)
  1008.             mark_table[i] = 0;
  1009.     }
  1010.  
  1011. #ifdef DEBUG
  1012.     if (debug) {
  1013.         printf("mark phase\n");
  1014.         fflush(stdout);
  1015.         tm = runtime();
  1016.     }
  1017. #endif
  1018. #ifdef SGC
  1019.     if(sgc_enabled)
  1020.       { if (t < t_end && tm_of(t)->tm_sgc == 0)
  1021.           {sgc_quit();
  1022.                if (siVnotify_gbc->s.s_dbind != Cnil)
  1023.           {fprintf(stdout, " (doing full gc)");
  1024.            fflush(stdout);}
  1025.            mark_phase();}
  1026.         else
  1027.       sgc_mark_phase();}
  1028.     else
  1029. #endif    
  1030.     mark_phase();
  1031. #ifdef DEBUG
  1032.     if (debug) {
  1033.         printf("mark ended (%d)\n", runtime() - tm);
  1034.         fflush(stdout);
  1035.     }
  1036. #endif
  1037.  
  1038. #ifdef DEBUG
  1039.     if (debug) {
  1040.         printf("sweep phase\n");
  1041.         fflush(stdout);
  1042.         tm = runtime();
  1043.     }
  1044. #endif
  1045. #ifdef SGC
  1046.     if(sgc_enabled)
  1047.       sgc_sweep_phase();
  1048.     else
  1049. #endif    
  1050.     sweep_phase();
  1051. #ifdef DEBUG
  1052.     if (debug) {
  1053.         printf("sweep ended (%d)\n", runtime() - tm);
  1054.         fflush(stdout);
  1055.     }
  1056. #endif
  1057.  
  1058.     if (t == t_contiguous) {
  1059. #ifdef DEBUG
  1060.         if (debug) {
  1061.             printf("contblock sweep phase\n");
  1062.             fflush(stdout);
  1063.             tm = runtime();
  1064.         }
  1065. #endif
  1066.  
  1067. #ifdef SGC
  1068.     if (sgc_enabled)
  1069.       sgc_contblock_sweep_phase();
  1070.     else
  1071. #endif
  1072.       contblock_sweep_phase();
  1073. #ifdef DEBUG
  1074.         if (debug)
  1075.             printf("contblock sweep ended (%d)\n",
  1076.                    runtime() - tm);
  1077. #endif
  1078.     }
  1079.  
  1080.     if ((int)t >= (int)t_contiguous) {
  1081.  
  1082.         if (rb_start < rb_start1) {
  1083.             j = (rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE;
  1084.             pp = (struct apage *)rb_start;
  1085.             qq = (struct apage *)rb_start1;
  1086.             for (i = 0;  i < j;  i++)
  1087.                 *pp++ = *qq++;
  1088.         }
  1089.  
  1090. #ifdef SGC
  1091.         /* we don't know which pages have relblock on them */
  1092.          if(sgc_enabled)
  1093.                   make_writable(page(rb_start),
  1094.                                 (rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE);
  1095.  
  1096. #endif        
  1097.         rb_limit = rb_end - 2*RB_GETA;
  1098.  
  1099.     }
  1100.  
  1101. #ifdef DEBUG
  1102.     if (debug) {
  1103.         for (i = 0, j = 0;  i < (int)t_end;  i++) {
  1104.             if (tm_table[i].tm_type == (enum type)i) {
  1105.                 printf("%13s: %8d used %8d free %4d/%d pages\n",
  1106.                        tm_table[i].tm_name,
  1107.                        TM_NUSED(tm_table[i]),
  1108.                        tm_table[i].tm_nfree,
  1109.                        tm_table[i].tm_npage,
  1110.                        tm_table[i].tm_maxpage);
  1111.                 j += tm_table[i].tm_npage;
  1112.             } else
  1113.                 printf("%13s: linked to %s\n",
  1114.                        tm_table[i].tm_name,
  1115.                        tm_table[(int)tm_table[i].tm_type].tm_name);
  1116.         }
  1117.         printf("contblock: %d blocks %d pages\n", ncb, ncbpage);
  1118.         printf("hole: %d pages\n", holepage);
  1119.         printf("relblock: %d bytes used %d bytes free %d pages\n",
  1120.                rb_pointer - rb_start, rb_end - rb_pointer, nrbpage);
  1121.         printf("GBC ended\n");
  1122.         fflush(stdout);
  1123.     }
  1124. #endif
  1125.  
  1126.     interrupt_enable = TRUE;
  1127.  
  1128.     if (saving_system) {
  1129.         j = (rb_pointer-rb_start+PAGESIZE-1) / PAGESIZE;
  1130.  
  1131.         heap_end += PAGESIZE*j;
  1132.  
  1133.         core_end = heap_end;
  1134.  
  1135.         for (i = 0;  i < maxpage;  i++)
  1136.             if ((enum type)type_map[i] == t_contiguous)
  1137.                 type_map[i] = (char)t_other;
  1138.         cb_pointer = NULL;
  1139.         maxcbpage -= ncbpage;
  1140.         if (maxcbpage < 100)
  1141.           maxcbpage = 100;
  1142.         ncbpage = 0;
  1143.         ncb = 0;
  1144.  
  1145.         if (sgc_enabled==0) holepage = new_holepage;
  1146.  
  1147.         nrbpage -= j;
  1148.         if (nrbpage < 0)
  1149.             error("no relocatable pages left");
  1150.  
  1151.         rb_start = heap_end + PAGESIZE*holepage;
  1152.         rb_end = rb_start + PAGESIZE*nrbpage;
  1153.         rb_limit = rb_end - 2*RB_GETA;
  1154.         rb_pointer = rb_start;
  1155.     }
  1156.  
  1157.     if (GBC_exit_hook != NULL)
  1158.         (*GBC_exit_hook)();
  1159.  
  1160.  
  1161.     if (in_sgc && sgc_enabled==0)
  1162.       sgc_start();
  1163.  
  1164.         if(gc_time>=0) {gc_time=gc_time+(gc_start=(runtime()-gc_start));}
  1165.  
  1166.     if (siVnotify_gbc->s.s_dbind != Cnil) {
  1167.  
  1168.       fprintf(stdout, "(T=%d).GC finished]\n",
  1169.           gc_start
  1170.           );
  1171.         fflush(stdout);
  1172.     }
  1173.  
  1174.  
  1175.     CHECK_FOR_INTERRUPT;
  1176. }
  1177.  
  1178. siLroom_report()
  1179. {
  1180.     int i;
  1181.  
  1182.     check_arg(0);
  1183.  
  1184. /*
  1185.     GBC(t_contiguous);
  1186. */
  1187.  
  1188.     vs_check_push(make_fixnum(real_maxpage));
  1189.     vs_push(make_fixnum(available_pages));
  1190.     vs_push(make_fixnum(ncbpage));
  1191.     vs_push(make_fixnum(maxcbpage));
  1192.     vs_push(make_fixnum(ncb));
  1193.     vs_push(make_fixnum(cbgbccount));
  1194.     vs_push(make_fixnum(holepage));
  1195.     vs_push(make_fixnum(rb_pointer - rb_start));
  1196.     vs_push(make_fixnum(rb_end - rb_pointer));
  1197.     vs_push(make_fixnum(nrbpage));
  1198.     vs_push(make_fixnum(rbgbccount));
  1199.     for (i = 0;  i < (int)t_end;  i++) {
  1200.         if (tm_table[i].tm_type == (enum type)i) {
  1201.             vs_check_push(make_fixnum(TM_NUSED(tm_table[i])));
  1202.             vs_push(make_fixnum(tm_table[i].tm_nfree));
  1203.             vs_push(make_fixnum(tm_table[i].tm_npage));
  1204.             vs_push(make_fixnum(tm_table[i].tm_maxpage));
  1205.             vs_push(make_fixnum(tm_table[i].tm_gbccount));
  1206.         } else {
  1207.             vs_check_push(Cnil);
  1208.             vs_push(make_fixnum(tm_table[i].tm_type));
  1209.             vs_push(Cnil);
  1210.             vs_push(Cnil);
  1211.             vs_push(Cnil);
  1212.         }
  1213.     }
  1214. }
  1215.  
  1216. siLreset_gbc_count()
  1217. {
  1218.     int i;
  1219.  
  1220.     check_arg(0);
  1221.     cbgbccount = 0;
  1222.     rbgbccount = 0;
  1223.     for (i = 0;  i < (int)t_end;  i++)
  1224.         tm_table[i].tm_gbccount = 0;
  1225. }
  1226.  
  1227. /* copy S bytes starting at P to beyond rb_pointer1 (temporarily)
  1228.  but return a pointer to where this will be copied back to,
  1229.  when gc is done.  alignment of rb_pointer is kept at a multiple
  1230.  of sizeof(char *);
  1231.  */
  1232.       
  1233. char *
  1234. copy_relblock(p, s)
  1235. char *p;
  1236. int s;
  1237. { char *res = rb_pointer;
  1238.   char *q = rb_pointer1;
  1239.   s = round_up(s);
  1240.   rb_pointer += s;
  1241.   rb_pointer1 += s;
  1242.   
  1243.   while (--s >= 0)
  1244.     { *q++ = *p++;}
  1245.  
  1246.   return res;
  1247. }
  1248.  
  1249.   
  1250. mark_contblock(p, s)
  1251. char *p;
  1252. int s;
  1253. {
  1254.     STATIC char *q;
  1255.     STATIC int *x, *y;
  1256.  
  1257.     if (!MAYBE_DATA_P(p) || (enum type)type_map[page(p)] != t_contiguous)
  1258.         return;
  1259.     q = p + s;
  1260.     x = (int *)(char *)((int)p&~3);
  1261.     y = (int *)(char *)(((int)q+3)&~3);
  1262.     for (;  x < y;  x++)
  1263.         set_mark_bit(x);
  1264. }
  1265.  
  1266. Lgbc()
  1267. {
  1268.     check_arg(1);
  1269.  
  1270.     if (vs_base[0] == Ct)
  1271.         GBC(t_contiguous);
  1272.     else if (vs_base[0] == Cnil)
  1273.         GBC(t_cons);
  1274.     else
  1275.         GBC(t_relocatable);
  1276. }
  1277.  
  1278. siLgbc_time()
  1279. {if (vs_top>vs_base)
  1280.    gc_time=fix(vs_base[0]);
  1281.  else
  1282.    {vs_base[0]=make_fixnum(gc_time);
  1283.     vs_top=vs_base+1;}
  1284. }
  1285.  
  1286. #ifdef SGC
  1287. #include "sgbc.c"
  1288. #endif
  1289.  
  1290. init_GBC()
  1291. {
  1292.     make_si_function("ROOM-REPORT", siLroom_report);
  1293.     make_si_function("RESET-GBC-COUNT", siLreset_gbc_count);
  1294.     make_si_function("GBC-TIME",siLgbc_time);
  1295.  
  1296.     siVnotify_gbc = make_si_special("*NOTIFY-GBC*", Cnil);
  1297.  
  1298. #ifdef DEBUG
  1299.     siVgbc_message = make_si_special("*GBC-MESSAGE*", Cnil);
  1300. #endif
  1301.  
  1302.     make_function("GBC", Lgbc);
  1303. #ifdef SGC
  1304.     /* we use that maxpage is a power of 2 in this
  1305.        case, to quickly be able to look in our table */ 
  1306.     {int i ;
  1307.      for(i=1 ; i< 32 ; i++)
  1308.        {if (MAXPAGE == (1 <<i))
  1309.           goto ok;}
  1310.      perror("MAXPAGE is not a power of 2.  Recompile");
  1311.      exit(1);
  1312.        ok:;}
  1313.     make_si_function("SGC-ON",siLsgc_on);
  1314. #endif    
  1315. }
  1316.  
  1317.