/[gcl]/gcl/o/gbc.c
ViewVC logotype

Diff of /gcl/o/gbc.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26