home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / c / gbc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  21.6 KB  |  1,108 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     GBC.c
  9.     IMPLEMENTATION-DEPENDENT
  10. */
  11.  
  12. #define    DEBUG
  13.  
  14. #include "include.h"
  15.  
  16. bool saving_system;
  17.  
  18. #define    round_up(n)    (((n) + 03) & ~03)
  19.  
  20. char *copy_relblock();
  21.  
  22. #ifdef AV
  23. #ifdef ATT3B2
  24. #define    page(p)        (((int)(char *)(p)-0x80800000)>>PAGEWIDTH)
  25. #define    pagetochar(x)    ((char *)(((x) << PAGEWIDTH) + 0x80800000))
  26. #else
  27. #define    page(p)        ((int)(char *)(p)>>PAGEWIDTH)
  28. #define    pagetochar(x)    ((char *)((x) << PAGEWIDTH))
  29. #endif
  30. #endif
  31.  
  32. #ifdef MV
  33.  
  34.  
  35. #endif
  36.  
  37.  
  38. int real_maxpage;
  39. int new_holepage;
  40.  
  41. #define    available_pages    \
  42.     (real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
  43.  
  44. struct apage {
  45.     char apage_self[PAGESIZE];
  46. };
  47.  
  48.  
  49. char *heap_end;
  50. char *core_end;
  51.  
  52. #define    inheap(pp)    ((char *)(pp) < heap_end)
  53.  
  54. int maxpage;
  55.  
  56. object siVnotify_gbc;
  57.  
  58. #ifdef DEBUG
  59. bool debug;
  60. object siVgbc_message;
  61. #endif
  62.  
  63. #define    MARK_ORIGIN_MAX        300
  64. #define    MARK_ORIGIN_BLOCK_MAX    20
  65.  
  66. #ifdef AV
  67. /*
  68.     See bitop.c.
  69. */
  70. #endif
  71. #ifdef MV
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86. #endif
  87.  
  88. #define    symbol_marked(x)    ((x)->d.m)
  89.  
  90. object *mark_origin[MARK_ORIGIN_MAX];
  91. int mark_origin_max;
  92.  
  93. struct {
  94.     object    *mob_addr;    /*  mark origin block address  */
  95.     int    mob_size;    /*  mark origin block size  */
  96. } mark_origin_block[MARK_ORIGIN_BLOCK_MAX];
  97. int mark_origin_block_max;
  98.  
  99. int *mark_table;
  100.  
  101. enum type what_to_collect;
  102.  
  103. bool GBC_enable;
  104.  
  105. enter_mark_origin(p)
  106. object *p;
  107. {
  108.     if (mark_origin_max >= MARK_ORIGIN_MAX)
  109.         error("too many mark origins");
  110.     mark_origin[mark_origin_max++] = p;
  111. }
  112.  
  113. enter_mark_origin_block(p, n)
  114. object *p;
  115. int n;
  116. {
  117.     if (mark_origin_block_max >= MARK_ORIGIN_BLOCK_MAX)
  118.         error("too many mark origin blocks");
  119.     mark_origin_block[mark_origin_block_max].mob_addr = p;
  120.     mark_origin_block[mark_origin_block_max++].mob_size = n;
  121. }
  122.  
  123. mark_cons(x)
  124. object x;
  125. {
  126. #ifdef AV
  127.     if ((int *)(&x) < cs_limit)
  128. #endif
  129. #ifdef MV
  130.  
  131. #endif
  132.         error("control stack overflow in GBC");
  133.  
  134.     /*  x is already marked.  */
  135. BEGIN:
  136.     if (x->c.c_car == OBJNULL)
  137.         ;
  138.     else if (type_of(x->c.c_car) == t_cons) {
  139.         if (x->c.c_car->c.m)
  140.             ;
  141.         else {
  142.             x->c.c_car->c.m = TRUE;
  143.             mark_cons(x->c.c_car);
  144.         }
  145.     } else
  146.         mark_object(x->c.c_car);
  147.     x = x->c.c_cdr;
  148.     if (x == OBJNULL)
  149.         return;
  150.     if (type_of(x) == t_cons) {
  151.         if (x->c.m)
  152.             return;
  153.         x->c.m = TRUE;
  154.         goto BEGIN;
  155.     }
  156.     if (x == Cnil)
  157.         return;
  158.     mark_object(x);
  159. }
  160.  
  161. mark_object(x)
  162. object x;
  163. {
  164.     int i, j;
  165.     object *p;
  166.     char *cp;
  167.     object y;
  168.  
  169. #ifdef AV
  170.     if ((int *)(&x) < cs_limit)
  171. #endif
  172. #ifdef MV
  173.  
  174. #endif
  175.         error("control stack overflow in GBC");
  176.  
  177. BEGIN:
  178.     if (x == OBJNULL)
  179.         return;
  180.     if (x->d.m)
  181.         return;
  182.     x->d.m = TRUE;
  183.     switch (type_of(x)) {
  184.     case t_fixnum:
  185.         break;
  186.  
  187.     case t_bignum:
  188.     BIGNUM:
  189.         x = (object)(x->big.big_cdr);
  190.         if ((struct bignum *)x == NULL)
  191.             break;
  192.         x->d.m = TRUE;
  193.         goto BIGNUM;
  194.  
  195.     case t_ratio:
  196.         mark_object(x->rat.rat_num);
  197.         x = x->rat.rat_den;
  198.         goto BEGIN;
  199.  
  200.     case t_shortfloat:
  201.         break;
  202.  
  203.     case t_longfloat:
  204.         break;
  205.  
  206.     case t_complex:
  207.         mark_object(x->cmp.cmp_imag);
  208.         x = x->cmp.cmp_real;
  209.         goto BEGIN;
  210.  
  211.     case t_character:
  212.         break;
  213.  
  214.     case t_symbol:
  215.         mark_object(x->s.s_plist);
  216.         mark_object(x->s.s_gfdef);
  217.         mark_object(x->s.s_dbind);
  218.         if (x->s.s_self == NULL)
  219.             break;
  220.         if ((int)what_to_collect >= (int)t_contiguous) {
  221.             if (inheap(x->s.s_self)) {
  222.                 if (what_to_collect == t_contiguous)
  223.                     mark_contblock(x->s.s_self,
  224.                                x->s.s_fillp);
  225.             } else
  226.                 x->s.s_self =
  227.                 copy_relblock(x->s.s_self, x->s.s_fillp);
  228.         }
  229.         break;
  230.  
  231.     case t_package:
  232.         mark_object(x->p.p_name);
  233.         mark_object(x->p.p_nicknames);
  234.         mark_object(x->p.p_shadowings);
  235.         mark_object(x->p.p_uselist);
  236.         mark_object(x->p.p_usedbylist);
  237.         if (what_to_collect != t_contiguous)
  238.             break;
  239.         if (x->p.p_internal != NULL)
  240.             mark_contblock((char *)(x->p.p_internal),
  241.                        PHTABSIZE*sizeof(object));
  242.         if (x->p.p_external != NULL)
  243.             mark_contblock((char *)(x->p.p_external),
  244.                        PHTABSIZE*sizeof(object));
  245.         break;
  246.  
  247.     case t_cons:
  248. /*
  249.         mark_object(x->c.c_car);
  250.         x = x->c.c_cdr;
  251.         goto BEGIN;
  252. */
  253.         mark_cons(x);
  254.         break;
  255.  
  256.     case t_hashtable:
  257.         mark_object(x->ht.ht_rhsize);
  258.         mark_object(x->ht.ht_rhthresh);
  259.         if (x->ht.ht_self == NULL)
  260.             break;
  261.         for (i = 0, j = x->ht.ht_size;  i < j;  i++) {
  262.             mark_object(x->ht.ht_self[i].hte_key);
  263.             mark_object(x->ht.ht_self[i].hte_value);
  264.         }
  265.         if ((short)what_to_collect >= (short)t_contiguous) {
  266.             if (inheap(x->ht.ht_self)) {
  267.                 if (what_to_collect == t_contiguous)
  268.                     mark_contblock((char *)(x->ht.ht_self),
  269.                                j * sizeof(struct htent));
  270.             } else
  271.                 x->ht.ht_self = (struct htent *)
  272.                 copy_relblock((char *)(x->ht.ht_self),
  273.                           j * sizeof(struct htent));
  274.         }
  275.         break;
  276.  
  277.     case t_array:
  278.         if ((y = x->a.a_displaced) != Cnil) {
  279.             /* BUG FIX for marking first word of displaced */
  280.             /* By Nick Gall */
  281.                         y->c.m = TRUE;
  282.             mark_object(y->c.c_car);
  283.             for (y = y->c.c_cdr;  y != Cnil;  y = y->c.c_cdr)
  284.                 y->c.m = TRUE;
  285.         }
  286.         if ((int)what_to_collect >= (int)t_contiguous &&
  287.             x->a.a_dims != NULL) {
  288.             if (inheap(x->a.a_dims)) {
  289.                 if (what_to_collect == t_contiguous)
  290.                     mark_contblock((char *)(x->a.a_dims),
  291.                                sizeof(int)*x->a.a_rank);
  292.             } else
  293.                 x->a.a_dims = (int *)
  294.                 copy_relblock((char *)(x->a.a_dims),
  295.                           sizeof(int)*x->a.a_rank);
  296.         }
  297.         if ((enum aelttype)x->a.a_elttype == aet_ch)
  298.             goto CASE_STRING;
  299.         if ((enum aelttype)x->a.a_elttype == aet_bit)
  300.             goto CASE_BITVECTOR;
  301.         if ((enum aelttype)x->a.a_elttype == aet_object)
  302.             goto CASE_GENERAL;
  303.  
  304.     CASE_SPECIAL:
  305.         cp = (char *)(x->fixa.fixa_self);
  306.         if (cp == NULL)
  307.             break;
  308.         if ((enum aelttype)x->a.a_elttype == aet_lf)
  309.             j = sizeof(longfloat)*x->lfa.lfa_dim;
  310.         else
  311.             j = sizeof(fixnum)*x->fixa.fixa_dim;
  312.         goto COPY;
  313.  
  314.     CASE_GENERAL:
  315.         p = x->a.a_self;
  316.         if (p == NULL)
  317.             break;
  318.         if (x->a.a_displaced->c.c_car == Cnil)
  319.             for (i = 0, j = x->a.a_dim;  i < j;  i++)
  320.                 mark_object(p[i]);
  321.         cp = (char *)p;
  322.         j *= sizeof(object);
  323.     COPY:
  324.         if ((int)what_to_collect >= (int)t_contiguous) {
  325.             if (inheap(cp)) {
  326.                 if (what_to_collect == t_contiguous)
  327.                     mark_contblock(cp, j);
  328.             } else if (x->a.a_displaced == Cnil)
  329.                 x->a.a_self = (object *)copy_relblock(cp, j);
  330.             else if (x->a.a_displaced->c.c_car == Cnil) {
  331.                 i = (int)(object *)copy_relblock(cp, j)
  332.                   - (int)(x->a.a_self);
  333.                 adjust_displaced(x, i);
  334.             }
  335.         }
  336.         break;
  337.  
  338.     case t_vector:
  339.         if ((y = x->v.v_displaced) != Cnil) {
  340.             /* BUG FIX for marking first word of displaced */
  341.             /* By Nick Gall */
  342.                         y->c.m = TRUE;
  343.             mark_object(y->c.c_car);
  344.             for (y = y->c.c_cdr;  y != Cnil;  y = y->c.c_cdr)
  345.                 y->c.m = TRUE;
  346.         }
  347.         if ((enum aelttype)x->v.v_elttype == aet_object)
  348.             goto CASE_GENERAL;
  349.         else
  350.             goto CASE_SPECIAL;
  351.  
  352.     CASE_STRING:
  353.     case t_string:
  354.         if ((y = x->st.st_displaced) != Cnil) {
  355.             /* BUG FIX for marking first word of displaced */
  356.             /* By Nick Gall */
  357.                         y->c.m = TRUE;
  358.             mark_object(y->c.c_car);
  359.             for (y = y->c.c_cdr;  y != Cnil;  y = y->c.c_cdr)
  360.                 y->c.m = TRUE;
  361.         }
  362.         j = x->st.st_dim;
  363.         cp = x->st.st_self;
  364.         if (cp == NULL)
  365.             break;
  366.     COPY_STRING:
  367.         if ((int)what_to_collect >= (int)t_contiguous) {
  368.             if (inheap(cp)) {
  369.                 if (what_to_collect == t_contiguous)
  370.                     mark_contblock(cp, j);
  371.             } else if (x->st.st_displaced == Cnil)
  372.                 x->st.st_self = copy_relblock(cp, j);
  373.             else if (x->st.st_displaced->c.c_car == Cnil) {
  374.                 i = copy_relblock(cp, j) - cp;
  375.                 adjust_displaced(x, i);
  376.             }
  377.         }
  378.         break;
  379.  
  380.     CASE_BITVECTOR:
  381.     case t_bitvector:
  382.         if ((y = x->bv.bv_displaced) != Cnil) {
  383.             /* BUG FIX for marking first word of displaced */
  384.             /* By Nick Gall */
  385.                         y->c.m = TRUE;
  386.             mark_object(y->c.c_car);
  387.             for (y = y->c.c_cdr;  y != Cnil;  y = y->c.c_cdr)
  388.                 y->c.m = TRUE;
  389.         }
  390.         j = (x->bv.bv_offset + x->bv.bv_dim + 7)/8;
  391.         cp = x->bv.bv_self;
  392.         if (cp == NULL)
  393.             break;
  394.         goto COPY_STRING;
  395.  
  396.     case t_structure:
  397.         mark_object(x->str.str_name);
  398.         p = x->str.str_self;
  399.         if (p == NULL)
  400.             break;
  401.         for (i = 0, j = x->str.str_length;  i < j;  i++)
  402.             mark_object(p[i]);
  403.         if ((int)what_to_collect >= (int)t_contiguous) {
  404.             if (inheap(x->str.str_self)) {
  405.                 if (what_to_collect == t_contiguous)
  406.                     mark_contblock((char *)p,
  407.                                j*sizeof(object));
  408.  
  409.             } else
  410.                 x->str.str_self = (object *)
  411.                 copy_relblock((char *)p, j*sizeof(object));
  412.         }
  413.         break;
  414.  
  415.     case t_stream:
  416.         switch (x->sm.sm_mode) {
  417.         case smm_input:
  418.         case smm_output:
  419.         case smm_io:
  420.         case smm_probe:
  421.             mark_object(x->sm.sm_object0);
  422.             mark_object(x->sm.sm_object1);
  423.             if (what_to_collect == t_contiguous &&
  424.                 x->sm.sm_fp != NULL &&
  425.                 x->sm.sm_fp->_base != NULL &&
  426.                 x->sm.sm_fp->_base != BASEFF)
  427.                 mark_contblock(x->sm.sm_fp->_base, BUFSIZ);
  428.             break;
  429.  
  430.         case smm_synonym:
  431.             mark_object(x->sm.sm_object0);
  432.             break;
  433.  
  434.         case smm_broadcast:
  435.         case smm_concatenated:
  436.             mark_object(x->sm.sm_object0);
  437.             break;
  438.  
  439.         case smm_two_way:
  440.         case smm_echo:
  441.             mark_object(x->sm.sm_object0);
  442.             mark_object(x->sm.sm_object1);
  443.             break;
  444.  
  445.         case smm_string_input:
  446.         case smm_string_output:
  447.             mark_object(x->sm.sm_object0);
  448.             break;
  449.  
  450.         default:
  451.             error("mark stream botch");
  452.         }
  453.         break;
  454.  
  455.     case t_random:
  456.         break;
  457.  
  458.     case t_readtable:
  459.         if (x->rt.rt_self == NULL)
  460.             break;
  461.         if (what_to_collect == t_contiguous)
  462.             mark_contblock((char *)(x->rt.rt_self),
  463.                        RTABSIZE*sizeof(struct rtent));
  464.         for (i = 0;  i < RTABSIZE;  i++) {
  465.             mark_object(x->rt.rt_self[i].rte_macro);
  466.             if (x->rt.rt_self[i].rte_dtab != NULL) {
  467. /**/
  468.     if (what_to_collect == t_contiguous)
  469.         mark_contblock((char *)(x->rt.rt_self[i].rte_dtab),
  470.                    RTABSIZE*sizeof(object));
  471.     for (j = 0;  j < RTABSIZE;  j++)
  472.         mark_object(x->rt.rt_self[i].rte_dtab[j]);
  473. /**/
  474.             }
  475.         }
  476.         break;
  477.  
  478.     case t_pathname:
  479.         mark_object(x->pn.pn_host);
  480.         mark_object(x->pn.pn_device);
  481.         mark_object(x->pn.pn_directory);
  482.         mark_object(x->pn.pn_name);
  483.         mark_object(x->pn.pn_type);
  484.         mark_object(x->pn.pn_version);
  485.         break;
  486.  
  487.     case t_cfun:
  488.         mark_object(x->cf.cf_name);
  489.         mark_object(x->cf.cf_data);
  490.         if (x->cf.cf_start == NULL)
  491.             break;
  492.         if (what_to_collect == t_contiguous) {
  493.             if (get_mark_bit((int *)(x->cf.cf_start)))
  494.                 break;
  495.             mark_contblock(x->cf.cf_start, x->cf.cf_size);
  496.         }
  497.         break;
  498.  
  499.     case t_cclosure:
  500.         mark_object(x->cc.cc_name);
  501.         mark_object(x->cc.cc_env);
  502.         mark_object(x->cc.cc_data);
  503.         if (x->cc.cc_start == NULL)
  504.             break;
  505.         if (what_to_collect == t_contiguous) {
  506.             if (get_mark_bit((int *)(x->cc.cc_start)))
  507.                 break;
  508.             mark_contblock(x->cc.cc_start, x->cc.cc_size);
  509.             if (x->cc.cc_turbo != NULL) {
  510.                 for (i = 0, y = x->cc.cc_env;
  511.                      type_of(y) == t_cons;
  512.                      i++, y = y->c.c_cdr);
  513.                 mark_contblock((char *)(x->cc.cc_turbo),
  514.                            i*sizeof(object));
  515.             }
  516.         }
  517.         break;
  518.  
  519.     case t_spice:
  520.         break;
  521.  
  522.     default:
  523. #ifdef DEBUG
  524.         if (debug)
  525.             printf("\ttype = %d\n", type_of(x));
  526. #endif
  527.         error("mark botch");
  528.     }
  529. }
  530.  
  531. mark_phase()
  532. {
  533.     STATIC object *p;
  534.     STATIC int i, j, k, n;
  535.     STATIC struct package *pp;
  536.     STATIC object s, l, *lp;
  537.     STATIC bds_ptr bdp;
  538.     STATIC frame_ptr frp;
  539.     STATIC ihs_ptr ihsp;
  540.     STATIC char *cp;
  541.  
  542.     mark_object(Cnil);
  543.     mark_object(Ct);
  544.  
  545.     for (p = vs_org;  p < vs_top;  p++) {
  546.         mark_object(*p);
  547.     }
  548.  
  549. #ifdef DEBUG
  550.     if (debug) {
  551.         printf("value stack marked\n");
  552.         fflush(stdout);
  553.     }
  554. #endif
  555.  
  556.     for (bdp = bds_org;  bdp<=bds_top;  bdp++) {
  557.          mark_object(bdp->bds_sym);
  558.         mark_object(bdp->bds_val);
  559.     }
  560.  
  561.     for (frp = frs_org;  frp <= frs_top;  frp++)
  562.         mark_object(frp->frs_val);
  563.  
  564.     for (ihsp = ihs_org;  ihsp <= ihs_top;  ihsp++)
  565.         mark_object(ihsp->ihs_function);
  566.  
  567.     for (i = 0;  i < mark_origin_max;  i++)
  568.         mark_object(*mark_origin[i]);
  569.     for (i = 0;  i < mark_origin_block_max;  i++)
  570.         for (j = 0;  j < mark_origin_block[i].mob_size;  j++)
  571.             mark_object(mark_origin_block[i].mob_addr[j]);
  572.  
  573.     for (pp = pack_pointer;  pp != NULL;  pp = pp->p_link)
  574.         mark_object(pp);
  575.  
  576. #ifdef DEBUG
  577.     if (debug) {
  578.         printf("symbol navigation\n");
  579.         fflush(stdout);
  580.     }
  581. #endif
  582.  
  583. /*
  584.     if (what_to_collect != t_symbol &&
  585.         (int)what_to_collect < (int)t_contiguous) {
  586. */
  587.         for (pp = pack_pointer;  pp != NULL;  pp = pp->p_link) {
  588.             if (pp->p_internal != NULL)
  589.                 for (i = 0;  i < PHTABSIZE;  i++)
  590.                     mark_object(pp->p_internal[i]);
  591.             if (pp->p_external != NULL)
  592.                 for (i = 0;  i < PHTABSIZE;  i++)
  593.                     mark_object(pp->p_external[i]);
  594.         }
  595. /*
  596.     The following code is now in the comment.
  597.     Interned symbols are never collocted.
  598.  
  599.         return;
  600.     }
  601.  
  602.     for (pp = pack_pointer;  pp != NULL;  pp = pp->p_link) {
  603.         if (pp->p_internal != NULL)
  604.         for (i = 0;  i < PHTABSIZE;  i++)
  605.             for (l=pp->p_internal[i]; !endp(l); l=l->c.c_cdr) {
  606.             s = l->c.c_car;
  607.             if (symbol_marked(s) ||
  608.                     s->s.s_hpack == (object)pp &&
  609.                     s->s.s_plist == Cnil &&
  610.                     s->s.s_sfdef == NOT_SPECIAL &&
  611.                     s->s.s_gfdef == OBJNULL &&
  612.                     s->s.s_dbind == OBJNULL &&
  613.                     s->s.s_stype == (short)stp_ordinary &&
  614.                     s->s.s_mflag == FALSE)
  615.                 ;
  616.             else
  617.                 mark_object(s);
  618.             }
  619.         if (pp->p_external != NULL)
  620.         for (i = 0;  i < PHTABSIZE;  i++)
  621.             mark_object(pp->p_external[i]);
  622.     }
  623.  
  624.     for (pp = pack_pointer;  pp != NULL;  pp = pp->p_link)
  625.         if (pp->p_internal != NULL)
  626.         for (i = 0;  i < PHTABSIZE;  i++)
  627.             for (lp = &(pp->p_internal[i]);  !endp(*lp);) {
  628.             s = (*lp)->c.c_car;
  629.             if (!symbol_marked(s))
  630.                 *lp = (*lp)->c.c_cdr;
  631.             else {
  632.                 (*lp)->d.m = TRUE;
  633.                 lp = &((*lp)->c.c_cdr);
  634.             }
  635.             }
  636. */
  637. }
  638.  
  639. sweep_phase()
  640. {
  641.     STATIC int i, j, k;
  642.     STATIC object x;
  643.     STATIC char *p;
  644.     STATIC int *ip;
  645.     STATIC struct typemanager *tm;
  646.     STATIC object f;
  647.  
  648.     Cnil->s.m = FALSE;
  649.     Ct->s.m = FALSE;
  650.  
  651. #ifdef DEBUG
  652.     if (debug)
  653.         printf("type map\n");
  654. #endif
  655.     for (i = 0;  i < maxpage;  i++) {
  656.         if (type_map[i] == (int)t_contiguous) {
  657.             if (debug) {
  658.                 printf("-");
  659.             /*
  660.                 fflush(stdout);
  661.             */
  662.                 continue;
  663.             }
  664.         }
  665.         if (type_map[i] >= (int)t_end)
  666.             continue;
  667.  
  668.         tm = tm_of((enum type)type_map[i]);
  669.  
  670.     /*
  671.         general sweeper
  672.     */
  673.  
  674. #ifdef DEBUG
  675.         if (debug) {
  676.             printf("%c", tm->tm_name[0]);
  677.         /*
  678.             fflush(stdout);
  679.         */
  680.         }
  681. #endif
  682.         p = pagetochar(i);
  683.         f = tm->tm_free;
  684.         k = 0;
  685.         for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) {
  686.             x = (object)p;
  687.             if (x->d.m == FREE)
  688.                 continue;
  689.             else if (x->d.m) {
  690.                 x->d.m = FALSE;
  691.                 continue;
  692.             }
  693.             switch (x->d.t) {
  694.             case t_array:
  695.             case t_vector:
  696.             case t_string:
  697.             case t_bitvector:
  698.                 if (x->a.a_displaced->c.c_car != Cnil)
  699.                     undisplace(x);
  700.             }
  701.             ((struct freelist *)x)->f_link = f;
  702.             x->d.m = FREE;
  703.             f = x;
  704.             k++;
  705.         }
  706.         tm->tm_free = f;
  707.         tm->tm_nfree += k;
  708.         tm->tm_nused -= k;
  709.  
  710.     NEXT_PAGE:
  711.         ;
  712.     }
  713. #ifdef DEBUG
  714.     if (debug) {
  715.         putchar('\n');
  716.         fflush(stdout);
  717.     }
  718. #endif
  719. }
  720.  
  721. contblock_sweep_phase()
  722. {
  723.     STATIC int i, j;
  724.     STATIC char *s, *e, *p, *q;
  725.     STATIC struct contblock *cbp;
  726.  
  727.     cb_pointer = NULL;
  728.     ncb = 0;
  729.     for (i = 0;  i < maxpage;) {
  730.         if (type_map[i] != (int)t_contiguous) {
  731.             i++;
  732.             continue;
  733.         }
  734.         for (j = i+1;
  735.              j < maxpage && type_map[j] == (int)t_contiguous;
  736.              j++)
  737.             ;    
  738.         s = pagetochar(i);
  739.         e = pagetochar(j);
  740.         for (p = s;  p < e;) {
  741.             if (get_mark_bit((int *)p)) {
  742.                 p += 4;
  743.                 continue;
  744.             }
  745.             q = p + 4;
  746.             while (q < e) {
  747.                 if (!get_mark_bit((int *)q)) {
  748.                     q += 4;
  749.                     continue;
  750.                 }
  751.                 break;
  752.             }
  753.             insert_contblock(p, q - p);
  754.             p = q + 4;
  755.         }
  756.         i = j + 1;
  757.     }
  758. #ifdef DEBUG
  759.     if (debug) {
  760.         for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link)
  761.             printf("%d-byte contblock\n", cbp->cb_size);
  762.         fflush(stdout);
  763.     }
  764. #endif
  765. }
  766.  
  767.  
  768. int (*GBC_enter_hook)() = NULL;
  769. int (*GBC_exit_hook)() = NULL;
  770.  
  771. GBC(t)
  772. enum type t;
  773. {
  774.     int i, j;
  775.     struct apage *pp, *qq;
  776.  
  777. #ifdef DEBUG
  778.     int tm;
  779. #endif
  780.  
  781.     if (siVnotify_gbc->s.s_dbind != Cnil) {
  782.         fprintf(stdout, "\nGBC invoked");
  783.         fflush(stdout);
  784.     }
  785.  
  786.     if (GBC_enter_hook != NULL)
  787.         (*GBC_enter_hook)();
  788.  
  789.     if (!GBC_enable)
  790.         error("GBC is not enabled");
  791.     interrupt_enable = FALSE;
  792.  
  793.     if (saving_system)
  794.         t = t_contiguous;
  795.  
  796. #ifdef DEBUG
  797.     debug = symbol_value(siVgbc_message) != Cnil;
  798. #endif
  799.  
  800.     what_to_collect = t;
  801.  
  802.     if (t == t_contiguous)
  803.         cbgbccount++;
  804.     else if (t == t_relocatable)
  805.         rbgbccount++;
  806.     else
  807.         tm_table[(int)t].tm_gbccount++;
  808.  
  809. #ifdef DEBUG
  810.     if (debug) {
  811.         if (t == t_contiguous)
  812.             printf("GBC entered for collecting contiguous blocks\n");
  813.         else if (t == t_relocatable)
  814.             printf("GBC entered for collecting relocatable blocks\n");
  815.         else
  816.             printf("GBC entered for collecting %s\n",
  817.                 tm_table[(int)t].tm_name);
  818.         fflush(stdout);
  819.     }
  820. #endif
  821.  
  822.     maxpage = page(heap_end);
  823.  
  824.     if ((int)t >= (int)t_contiguous) {
  825.         j = maxpage*16;
  826.         /*
  827.             1 page = 512 long word
  828.             512 bit = 16 long word
  829.         */
  830.  
  831.         if (t == t_relocatable)
  832.             j = 0;
  833.  
  834.         if (holepage < new_holepage)
  835.             holepage = new_holepage;
  836.  
  837.         i = rb_pointer - rb_start;
  838.  
  839.         if (nrbpage > (real_maxpage-page(heap_end)
  840.                        -holepage-real_maxpage/32)/2) {
  841.             if (i > nrbpage*PAGESIZE)
  842.                 error("Can't allocate.  Good-bye!.");
  843.             else
  844.                 nrbpage =
  845.                 (real_maxpage-page(heap_end)
  846.                  -holepage-real_maxpage/32)/2;
  847.         }
  848.  
  849.         if (saving_system)
  850.             rb_start = heap_end;
  851.         else
  852.             rb_start = heap_end + PAGESIZE*holepage;
  853.  
  854.         rb_end = rb_start + PAGESIZE*nrbpage;
  855.  
  856.         if (rb_start < rb_pointer)
  857.             rb_start1 = (char *)
  858.             ((int)(rb_pointer + PAGESIZE-1) & -PAGESIZE);
  859.         else
  860.             rb_start1 = rb_start;
  861.  
  862.         rb_pointer = rb_start;
  863.         rb_pointer1 = rb_start1;
  864.  
  865.         mark_table = (int *)(rb_start1 + i);
  866.  
  867.         if (rb_end < (char *)&mark_table[j])
  868.             i = (char *)&mark_table[j] - heap_end;
  869.         else
  870.             i = rb_end - heap_end;
  871.         alloc_page(-(i + PAGESIZE - 1)/PAGESIZE);
  872.  
  873.         for (i = 0;  i < j; i++)
  874.             mark_table[i] = 0;
  875.     }
  876.  
  877. #ifdef DEBUG
  878.     if (debug) {
  879.         printf("mark phase\n");
  880.         fflush(stdout);
  881.         tm = runtime();
  882.     }
  883. #endif
  884.     mark_phase();
  885. #ifdef DEBUG
  886.     if (debug) {
  887.         printf("mark ended (%d)\n", runtime() - tm);
  888.         fflush(stdout);
  889.     }
  890. #endif
  891.  
  892. #ifdef DEBUG
  893.     if (debug) {
  894.         printf("sweep phase\n");
  895.         fflush(stdout);
  896.         tm = runtime();
  897.     }
  898. #endif
  899.     sweep_phase();
  900. #ifdef DEBUG
  901.     if (debug) {
  902.         printf("sweep ended (%d)\n", runtime() - tm);
  903.         fflush(stdout);
  904.     }
  905. #endif
  906.  
  907.     if (t == t_contiguous) {
  908. #ifdef DEBUG
  909.         if (debug) {
  910.             printf("contblock sweep phase\n");
  911.             fflush(stdout);
  912.             tm = runtime();
  913.         }
  914. #endif
  915.         contblock_sweep_phase();
  916. #ifdef DEBUG
  917.         if (debug)
  918.             printf("contblock sweep ended (%d)\n",
  919.                    runtime() - tm);
  920. #endif
  921.     }
  922.  
  923.     if ((int)t >= (int)t_contiguous) {
  924.  
  925.         if (rb_start < rb_start1) {
  926.             j = (rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE;
  927.             pp = (struct apage *)rb_start;
  928.             qq = (struct apage *)rb_start1;
  929.             for (i = 0;  i < j;  i++)
  930.                 *pp++ = *qq++;
  931.         }
  932.  
  933.         rb_limit = rb_end - 2*RB_GETA;
  934.  
  935.     }
  936.  
  937. #ifdef DEBUG
  938.     if (debug) {
  939.         for (i = 0, j = 0;  i < (int)t_end;  i++) {
  940.             if (tm_table[i].tm_type == (enum type)i) {
  941.                 printf("%13s: %8d used %8d free %4d/%d pages\n",
  942.                        tm_table[i].tm_name,
  943.                        tm_table[i].tm_nused,
  944.                        tm_table[i].tm_nfree,
  945.                        tm_table[i].tm_npage,
  946.                        tm_table[i].tm_maxpage);
  947.                 j += tm_table[i].tm_npage;
  948.             } else
  949.                 printf("%13s: linked to %s\n",
  950.                        tm_table[i].tm_name,
  951.                        tm_table[(int)tm_table[i].tm_type].tm_name);
  952.         }
  953.         printf("contblock: %d blocks %d pages\n", ncb, ncbpage);
  954.         printf("hole: %d pages\n", holepage);
  955.         printf("relblock: %d bytes used %d bytes free %d pages\n",
  956.                rb_pointer - rb_start, rb_end - rb_pointer, nrbpage);
  957.         printf("GBC ended\n");
  958.         fflush(stdout);
  959.     }
  960. #endif
  961.  
  962.     interrupt_enable = TRUE;
  963.  
  964.     if (saving_system) {
  965.         j = (rb_pointer-rb_start+PAGESIZE-1) / PAGESIZE;
  966.  
  967.         heap_end += PAGESIZE*j;
  968.  
  969.         core_end = heap_end;
  970.  
  971.         for (i = 0;  i < maxpage;  i++)
  972.             if ((enum type)type_map[i] == t_contiguous)
  973.                 type_map[i] = (char)t_other;
  974.         cb_pointer = NULL;
  975.         maxcbpage -= ncbpage;
  976.         ncbpage = 0;
  977.         ncb = 0;
  978.  
  979.         holepage = new_holepage;
  980.  
  981.         nrbpage -= j;
  982.         if (nrbpage <= 0)
  983.             error("no relocatable pages left");
  984.  
  985.         rb_start = heap_end + PAGESIZE*holepage;
  986.         rb_end = rb_start + PAGESIZE*nrbpage;
  987.         rb_limit = rb_end - 2*RB_GETA;
  988.         rb_pointer = rb_start;
  989.     }
  990.  
  991.     if (GBC_exit_hook != NULL)
  992.         (*GBC_exit_hook)();
  993.  
  994.     if (siVnotify_gbc->s.s_dbind != Cnil) {
  995.         fprintf(stdout, "\nGBC finished\n");
  996.         fflush(stdout);
  997.     }
  998. }
  999.  
  1000. siLroom_report()
  1001. {
  1002.     int i;
  1003.  
  1004.     check_arg(0);
  1005.  
  1006. /*
  1007.     GBC(t_contiguous);
  1008. */
  1009.  
  1010.     vs_check_push(make_fixnum(real_maxpage));
  1011.     vs_push(make_fixnum(available_pages));
  1012.     vs_push(make_fixnum(ncbpage));
  1013.     vs_push(make_fixnum(maxcbpage));
  1014.     vs_push(make_fixnum(ncb));
  1015.     vs_push(make_fixnum(cbgbccount));
  1016.     vs_push(make_fixnum(holepage));
  1017.     vs_push(make_fixnum(rb_pointer - rb_start));
  1018.     vs_push(make_fixnum(rb_end - rb_pointer));
  1019.     vs_push(make_fixnum(nrbpage));
  1020.     vs_push(make_fixnum(rbgbccount));
  1021.     for (i = 0;  i < (int)t_end;  i++) {
  1022.         if (tm_table[i].tm_type == (enum type)i) {
  1023.             vs_check_push(make_fixnum(tm_table[i].tm_nused));
  1024.             vs_push(make_fixnum(tm_table[i].tm_nfree));
  1025.             vs_push(make_fixnum(tm_table[i].tm_npage));
  1026.             vs_push(make_fixnum(tm_table[i].tm_maxpage));
  1027.             vs_push(make_fixnum(tm_table[i].tm_gbccount));
  1028.         } else {
  1029.             vs_check_push(Cnil);
  1030.             vs_push(make_fixnum(tm_table[i].tm_type));
  1031.             vs_push(Cnil);
  1032.             vs_push(Cnil);
  1033.             vs_push(Cnil);
  1034.         }
  1035.     }
  1036. }
  1037.  
  1038. siLreset_gbc_count()
  1039. {
  1040.     int i;
  1041.  
  1042.     check_arg(0);
  1043.     cbgbccount = 0;
  1044.     rbgbccount = 0;
  1045.     for (i = 0;  i < (int)t_end;  i++)
  1046.         tm_table[i].tm_gbccount = 0;
  1047. }
  1048.  
  1049. char *
  1050. copy_relblock(p, s)
  1051. char *p;
  1052. int s;
  1053. {
  1054.     STATIC char *q, *e;
  1055.  
  1056.     s = round_up(s);
  1057.     e = p + s;
  1058.     q = rb_pointer1;
  1059.     while (p < e)
  1060.         *q++ = *p++;
  1061.     q = rb_pointer;
  1062.     rb_pointer += s;
  1063.     rb_pointer1 += s;
  1064.     return(q);
  1065. }
  1066.  
  1067. mark_contblock(p, s)
  1068. char *p;
  1069. int s;
  1070. {
  1071.     STATIC char *q;
  1072.     STATIC int *x, *y;
  1073.  
  1074.     if ((enum type)type_map[page(p)] != t_contiguous)
  1075.         return;
  1076.     q = p + s;
  1077.     x = (int *)(char *)((int)p&~3);
  1078.     y = (int *)(char *)(((int)q+3)&~3);
  1079.     for (;  x < y;  x++)
  1080.         set_mark_bit(x);
  1081. }
  1082.  
  1083. Lgbc()
  1084. {
  1085.     check_arg(1);
  1086.  
  1087.     if (vs_base[0] == Ct)
  1088.         GBC(t_contiguous);
  1089.     else if (vs_base[0] == Cnil)
  1090.         GBC(t_cons);
  1091.     else
  1092.         GBC(t_relocatable);
  1093. }
  1094.  
  1095. init_GBC()
  1096. {
  1097.     make_si_function("ROOM-REPORT", siLroom_report);
  1098.     make_si_function("RESET-GBC-COUNT", siLreset_gbc_count);
  1099.  
  1100.     siVnotify_gbc = make_si_special("*NOTIFY-GBC*", Cnil);
  1101.  
  1102. #ifdef DEBUG
  1103.     siVgbc_message = make_si_special("*GBC-MESSAGE*", Cnil);
  1104. #endif
  1105.  
  1106.     make_function("GBC", Lgbc);
  1107. }
  1108.