source: trunk/source/lisp-kernel/gc-common.c @ 9901

Last change on this file since 9901 was 9901, checked in by gb, 12 years ago

Remove unused variables. (May need to compile with -Wall to find
more unused vars on PPC, too.)

File size: 34.2 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp_globals.h"
19#include "bits.h"
20#include "gc.h"
21#include "area.h"
22#include "Threads.h"
23#include <stddef.h>
24#include <stdlib.h>
25#include <string.h>
26
27#ifndef WINDOWS
28#include <sys/time.h>
29#endif
30
31#ifndef timeradd
32# define timeradd(a, b, result)                                               \
33  do {                                                                        \
34    (result)->tv_sec = (a)->tv_sec + (b)->tv_sec;                             \
35    (result)->tv_usec = (a)->tv_usec + (b)->tv_usec;                          \
36    if ((result)->tv_usec >= 1000000)                                         \
37      {                                                                       \
38        ++(result)->tv_sec;                                                   \
39        (result)->tv_usec -= 1000000;                                         \
40      }                                                                       \
41  } while (0)
42#endif
43#ifndef timersub
44# define timersub(a, b, result)                                               \
45  do {                                                                        \
46    (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;                             \
47    (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;                          \
48    if ((result)->tv_usec < 0) {                                              \
49      --(result)->tv_sec;                                                     \
50      (result)->tv_usec += 1000000;                                           \
51    }                                                                         \
52  } while (0)
53#endif
54
55void
56comma_output_decimal(char *buf, int len, natural n) 
57{
58  int nout = 0;
59
60  buf[--len] = 0;
61  do {
62    buf[--len] = n%10+'0';
63    n = n/10;
64    if (n == 0) {
65      while (len) {
66        buf[--len] = ' ';
67      }
68      return;
69    }
70    if (len == 0) return;
71    nout ++;
72    if (nout == 3) {
73      buf[--len] = ',';
74      nout = 0;
75    }
76  } while (len >= 0);
77}
78
79
80natural
81static_dnodes_for_area(area *a)
82{
83  if (a->low == tenured_area->low) {
84    return tenured_area->static_dnodes;
85  }
86  return 0;
87}
88
89Boolean GCDebug = false, GCverbose = false;
90bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL;
91LispObj GCarealow = 0, GCareadynamiclow = 0;
92natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0;
93LispObj GCweakvll = (LispObj)NULL;
94LispObj GCdwsweakvll = (LispObj)NULL;
95LispObj GCephemeral_low = 0;
96natural GCn_ephemeral_dnodes = 0;
97natural GCstack_limit = 0;
98
99
100void
101reapweakv(LispObj weakv)
102{
103  /*
104    element 2 of the weak vector should be tagged as a cons: if it
105    isn't, just mark it as a root.  if it is, cdr through it until a
106    "marked" cons is encountered.  If the car of any unmarked cons is
107    marked, mark the cons which contains it; otherwise, splice the
108    cons out of the list.  N.B. : elements 0 and 1 are already marked
109    (or are immediate, etc.)
110  */
111  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
112  LispObj termination_list = lisp_nil;
113  natural weak_type = (natural) deref(weakv,2);
114  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
115    terminatablep = ((weak_type >> population_termination_bit) != 0);
116  Boolean done = false;
117  cons *rawcons;
118  natural dnode, car_dnode;
119  bitvector markbits = GCmarkbits;
120
121  if (terminatablep) {
122    termination_list = deref(weakv,1+3);
123  }
124
125  if (fulltag_of(cell) != fulltag_cons) {
126    mark_root(cell);
127  } else if (alistp) {
128    /* weak alist */
129    while (! done) {
130      dnode = gc_area_dnode(cell);
131      if ((dnode >= GCndnodes_in_area) ||
132          (ref_bit(markbits, dnode))) {
133        done = true;
134      } else {
135        /* Cons cell is unmarked. */
136        LispObj alist_cell, thecar;
137        unsigned cell_tag;
138
139        rawcons = (cons *) ptr_from_lispobj(untag(cell));
140        alist_cell = rawcons->car;
141        cell_tag = fulltag_of(alist_cell);
142
143        if ((cell_tag == fulltag_cons) &&
144            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
145            (! ref_bit(markbits, car_dnode)) &&
146            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
147            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
148            (! ref_bit(markbits, car_dnode))) {
149          *prev = rawcons->cdr;
150          if (terminatablep) {
151            rawcons->cdr = termination_list;
152            termination_list = cell;
153          }
154        } else {
155          set_bit(markbits, dnode);
156          prev = (LispObj *)(&(rawcons->cdr));
157          mark_root(alist_cell);
158        }
159        cell = *prev;
160      }
161    }
162  } else {
163    /* weak list */
164    while (! done) {
165      dnode = gc_area_dnode(cell);
166      if ((dnode >= GCndnodes_in_area) ||
167          (ref_bit(markbits, dnode))) {
168        done = true;
169      } else {
170        /* Cons cell is unmarked. */
171        LispObj thecar;
172        unsigned cartag;
173
174        rawcons = (cons *) ptr_from_lispobj(untag(cell));
175        thecar = rawcons->car;
176        cartag = fulltag_of(thecar);
177
178        if (is_node_fulltag(cartag) &&
179            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
180            (! ref_bit(markbits, car_dnode))) {
181          *prev = rawcons->cdr;
182          if (terminatablep) {
183            rawcons->cdr = termination_list;
184            termination_list = cell;
185          }
186        } else {
187          set_bit(markbits, dnode);
188          prev = (LispObj *)(&(rawcons->cdr));
189        }
190        cell = *prev;
191      }
192    }
193  }
194
195  if (terminatablep) {
196    deref(weakv,1+3) = termination_list;
197    if (termination_list != lisp_nil) {
198      deref(weakv,1) = GCweakvll;
199      GCweakvll = weakv;
200    }
201  }
202}
203
204/*
205  Screw: doesn't deal with finalization.
206  */
207
208void
209reaphashv(LispObj hashv)
210{
211  hash_table_vector_header
212    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
213  natural
214    dnode,
215    npairs = (header_element_count(hashp->header) - 
216              (hash_table_vector_header_count -1)) >> 1;
217  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
218  Boolean
219    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
220  bitvector markbits = GCmarkbits;
221  int tag;
222
223  while (npairs--) {
224    if (weak_on_value) {
225      weakelement = pairp[1];
226    } else {
227      weakelement = pairp[0];
228    }
229    tag = fulltag_of(weakelement);
230    if (is_node_fulltag(tag)) {
231      dnode = gc_area_dnode(weakelement);
232      if ((dnode < GCndnodes_in_area) && 
233          ! ref_bit(markbits, dnode)) {
234        pairp[0] = slot_unbound;
235        pairp[1] = lisp_nil;
236        hashp->weak_deletions_count += (1<<fixnumshift);
237      }
238    }
239    pairp += 2;
240  }
241}
242
243void
244traditional_dws_mark_htabv(LispObj htabv)
245{
246  /* Do nothing, just add htabv to GCweakvll */
247  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
248 
249  deref(base,1) = GCweakvll;
250  GCweakvll = htabv;
251}
252
253void
254ncircle_dws_mark_htabv(LispObj htabv)
255{
256  /* Do nothing, just add htabv to GCdwsweakvll */
257  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
258 
259  deref(base,1) = GCdwsweakvll;
260  GCdwsweakvll = htabv;
261}
262
263void
264traditional_mark_weak_htabv(LispObj htabv)
265{
266  int i, skip = hash_table_vector_header_count;;
267
268  for (i = 2; i <= skip; i++) {
269    rmark(deref(htabv,i));
270  }
271
272  deref(htabv,1) = GCweakvll;
273  GCweakvll = htabv;
274}
275
276void
277ncircle_mark_weak_htabv(LispObj htabv)
278{
279  int i, skip = hash_table_vector_header_count;
280  hash_table_vector_header *hashp = (hash_table_vector_header *)(untag(htabv));
281  natural
282    npairs = (header_element_count(hashp->header) - 
283              (hash_table_vector_header_count - 1)) >> 1;
284  LispObj *pairp = (LispObj*) (hashp+1);
285  Boolean
286    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
287
288
289  for (i = 2; i <= skip; i++) {
290    rmark(deref(htabv,i));
291  }
292 
293  if (!weak_on_value) {
294    pairp++;
295  }
296  /* unconditionally mark the non-weak element of each pair */
297  while (npairs--) {
298    rmark(*pairp);
299    pairp += 2;
300  }
301
302  deref(htabv,1) = GCweakvll;
303  GCweakvll = htabv;
304}
305
306
307Boolean
308mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
309{
310  natural flags = hashp->flags, key_dnode, val_dnode;
311  Boolean
312    marked_new = false, 
313    key_marked,
314    val_marked,
315    weak_value = ((flags & nhash_weak_value_mask) != 0);
316  int 
317    skip = hash_table_vector_header_count-1,
318    key_tag,
319    val_tag,
320    i;
321  LispObj
322    *pairp = (LispObj*) (hashp+1),
323    key,
324    val;
325
326  /* Mark everything in the header */
327 
328  for (i = 2; i<= skip; i++) {
329    mark_root(deref(ptr_to_lispobj(hashp),i));
330  }
331
332  elements -= skip;
333
334  for (i = 0; i<elements; i+=2, pairp+=2) {
335    key = pairp[0];
336    val = pairp[1];
337    key_marked = val_marked = true;
338    key_tag = fulltag_of(key);
339    val_tag = fulltag_of(val);
340    if (is_node_fulltag(key_tag)) {
341      key_dnode = gc_area_dnode(key);
342      if ((key_dnode < GCndnodes_in_area) &&
343          ! ref_bit(GCmarkbits,key_dnode)) {
344        key_marked = false;
345      }
346    }
347    if (is_node_fulltag(val_tag)) {
348      val_dnode = gc_area_dnode(val);
349      if ((val_dnode < GCndnodes_in_area) &&
350          ! ref_bit(GCmarkbits,val_dnode)) {
351        val_marked = false;
352      }
353    }
354
355    if (weak_value) {
356      if (val_marked & !key_marked) {
357        mark_root(key);
358        marked_new = true;
359      }
360    } else {
361      if (key_marked & !val_marked) {
362        mark_root(val);
363        marked_new = true;
364      }
365    }
366  }
367  return marked_new;
368}
369
370
371Boolean
372mark_weak_alist(LispObj weak_alist, int weak_type)
373{
374  natural
375    elements = header_element_count(header_of(weak_alist)),
376    dnode;
377  int pair_tag;
378  Boolean marked_new = false;
379  LispObj alist, pair, key, value;
380  bitvector markbits = GCmarkbits;
381
382  if (weak_type >> population_termination_bit) {
383    elements -= 1;
384  }
385  for(alist = deref(weak_alist, elements);
386      (fulltag_of(alist) == fulltag_cons) &&
387      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
388      (! ref_bit(markbits,dnode));
389      alist = cdr(alist)) {
390    pair = car(alist);
391    pair_tag = fulltag_of(pair);
392    if ((is_node_fulltag(pair_tag)) &&
393        ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) &&
394        (! ref_bit(markbits,dnode))) {
395      if (pair_tag == fulltag_cons) {
396        key = car(pair);
397        if ((! is_node_fulltag(fulltag_of(key))) ||
398            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
399            ref_bit(markbits,dnode)) {
400          /* key is marked, mark value if necessary */
401          value = cdr(pair);
402          if (is_node_fulltag(fulltag_of(value)) &&
403              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
404              (! ref_bit(markbits,dnode))) {
405            mark_root(value);
406            marked_new = true;
407          }
408        }
409      } else {
410          mark_root(pair);
411          marked_new = true;
412      }
413    }
414  }
415  return marked_new;
416}
417 
418void
419traditional_markhtabvs()
420{
421  LispObj this, header, pending;
422  int subtag;
423  hash_table_vector_header *hashp;
424  Boolean marked_new;
425
426  do {
427    pending = (LispObj) NULL;
428    marked_new = false;
429   
430    while (GCweakvll) {
431      this = GCweakvll;
432      GCweakvll = deref(this,1);
433     
434      header = header_of(this);
435      subtag = header_subtag(header);
436     
437      if (subtag == subtag_weak) {
438        natural weak_type = deref(this,2);
439        deref(this,1) = pending;
440        pending = this;
441        if ((weak_type & population_type_mask) == population_weak_alist) {
442          if (mark_weak_alist(this, weak_type)) {
443            marked_new = true;
444          }
445        }
446      } else if (subtag == subtag_hash_vector) {
447        natural elements = header_element_count(header);
448
449        hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this));
450        if (hashp->flags & nhash_weak_mask) {
451          deref(this,1) = pending;
452          pending = this;
453          if (mark_weak_hash_vector(hashp, elements)) {
454            marked_new = true;
455          }
456        } 
457      } else {
458        Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this);
459      }
460    }
461
462    if (marked_new) {
463      GCweakvll = pending;
464    }
465  } while (marked_new);
466
467  /* Now, everything's marked that's going to be,  and "pending" is a list
468     of populations and weak hash tables.  CDR down that list and free
469     anything that isn't marked.
470     */
471
472  while (pending) {
473    this = pending;
474    pending = deref(this,1);
475    deref(this,1) = (LispObj)NULL;
476
477    subtag = header_subtag(header_of(this));
478    if (subtag == subtag_weak) {
479      reapweakv(this);
480    } else {
481      reaphashv(this);
482    }
483  }
484
485  /* Finally, mark the termination lists in all terminatable weak vectors
486     They are now linked together on GCweakvll.
487     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
488     but it will force terminatable popualations to hold on to each other
489     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
490     */
491  pending = GCweakvll;
492  GCweakvll = (LispObj)NULL;
493  while (pending) {
494    this = pending;
495    pending = deref(this,1);
496    deref(this,1) = (LispObj)NULL;
497    mark_root(deref(this,1+3));
498  }
499}
500
501void
502ncircle_markhtabvs()
503{
504  LispObj this, header, pending = 0;
505  int subtag;
506  Boolean marked_new;
507
508  /* First, process any weak hash tables that may have
509     been encountered by the link-inverting marker; we
510     should have more stack space now. */
511
512  while (GCdwsweakvll) {
513    this = GCdwsweakvll;
514    GCdwsweakvll = deref(this,1);
515    ncircle_mark_weak_htabv(this);
516  }
517
518  while (GCweakvll) {
519    this = GCweakvll;
520    GCweakvll = deref(this,1);
521     
522    header = header_of(this);
523    subtag = header_subtag(header);
524     
525    if (subtag == subtag_weak) {
526      natural weak_type = deref(this,2);
527      deref(this,1) = pending;
528      pending = this;
529      if ((weak_type & population_type_mask) == population_weak_alist) {
530        if (mark_weak_alist(this, weak_type)) {
531          marked_new = true;
532          }
533      }
534    } else if (subtag == subtag_hash_vector) {
535      reaphashv(this);
536    }
537  }
538
539  /* Now, everything's marked that's going to be,  and "pending" is a list
540     of populations.  CDR down that list and free
541     anything that isn't marked.
542     */
543
544  while (pending) {
545    this = pending;
546    pending = deref(this,1);
547    deref(this,1) = (LispObj)NULL;
548
549    subtag = header_subtag(header_of(this));
550    if (subtag == subtag_weak) {
551      reapweakv(this);
552    } else {
553      Bug(NULL, "Bad object on pending list: %s\n", this);
554    }
555  }
556
557  /* Finally, mark the termination lists in all terminatable weak vectors
558     They are now linked together on GCweakvll.
559     This is where to store  lisp_global(TERMINATION_LIST) if we decide to do that,
560     but it will force terminatable popualations to hold on to each other
561     (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)).
562     */
563  pending = GCweakvll;
564  GCweakvll = (LispObj)NULL;
565  while (pending) {
566    this = pending;
567    pending = deref(this,1);
568    deref(this,1) = (LispObj)NULL;
569    mark_root(deref(this,1+3));
570  }
571}
572
573void
574mark_tcr_tlb(TCR *tcr)
575{
576  natural n = tcr->tlb_limit;
577  LispObj
578    *start = tcr->tlb_pointer,
579    *end = (LispObj *) ((BytePtr)start+n),
580    node;
581
582  while (start < end) {
583    node = *start;
584    if (node != no_thread_local_binding_marker) {
585      mark_root(node);
586    }
587    start++;
588  }
589}
590
591/*
592  Mark things that're only reachable through some (suspended) TCR.
593  (This basically means the tcr's gc_context and the exception
594  frames on its xframe_list.)
595*/
596
597void
598mark_tcr_xframes(TCR *tcr)
599{
600  xframe_list *xframes;
601  ExceptionInformation *xp;
602
603  xp = tcr->gc_context;
604  if (xp) {
605    mark_xp(xp);
606  }
607 
608  for (xframes = (xframe_list *) tcr->xframe; 
609       xframes; 
610       xframes = xframes->prev) {
611      mark_xp(xframes->curr);
612  }
613}
614     
615
616void *postGCptrs = NULL;
617
618void
619postGCfree(void *p)
620{
621  *(void **)p = postGCptrs;
622  postGCptrs = p;
623}
624
625void
626freeGCptrs()
627{
628  void *p, *next;
629
630  for (p = postGCptrs; p; p = next) {
631    next = *((void **)p);
632    free(p);
633  }
634  postGCptrs = NULL;
635}
636
637void
638reap_gcable_ptrs()
639{
640  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
641  xmacptr_flag flag;
642  natural dnode;
643  xmacptr *x;
644
645  while((next = *prev) != (LispObj)NULL) {
646    dnode = gc_area_dnode(next);
647    x = (xmacptr *) ptr_from_lispobj(untag(next));
648
649    if ((dnode >= GCndnodes_in_area) ||
650        (ref_bit(GCmarkbits,dnode))) {
651      prev = &(x->link);
652    } else {
653      *prev = x->link;
654      flag = (xmacptr_flag)(x->flags);
655      ptr = x->address;
656
657      if (ptr) {
658        switch (flag) {
659        case xmacptr_flag_recursive_lock:
660          destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr));
661          break;
662
663        case xmacptr_flag_ptr:
664          postGCfree((void *)ptr_from_lispobj(ptr));
665          break;
666
667        case xmacptr_flag_rwlock:
668          rwlock_destroy((rwlock *)ptr_from_lispobj(ptr));
669          break;
670
671        case xmacptr_flag_semaphore:
672          destroy_semaphore((void**)&(x->address));
673          break;
674
675        default:
676          /* (warn "unknown xmacptr_flag: ~s" flag) */
677          /* Unknowd, and perhaps unknowdable. */
678          /* Fall in: */
679        case xmacptr_flag_none:
680          break;
681        }
682      }
683    }
684  }
685}
686
687
688
689#if  WORD_SIZE == 64
690unsigned short *_one_bits = NULL;
691
692unsigned short
693logcount16(unsigned short n)
694{
695  unsigned short c=0;
696 
697  while(n) {
698    n = n & (n-1);
699    c++;
700  }
701  return c;
702}
703
704void
705gc_init()
706{
707  int i;
708 
709  _one_bits = malloc(sizeof(unsigned short) * (1<<16));
710
711  for (i = 0; i < (1<<16); i++) {
712    _one_bits[i] = dnode_size*logcount16(i);
713  }
714}
715
716
717#else
718const unsigned char _one_bits[256] = {
719    0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,
720    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
721    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
722    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
723    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
724    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
725    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
726    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
727    1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,
728    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
729    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
730    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
731    2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,
732    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
733    3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,
734    4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8
735};
736
737
738void
739gc_init()
740{
741}
742
743#endif
744
745
746weak_mark_fun dws_mark_weak_htabv = traditional_dws_mark_htabv;
747weak_mark_fun mark_weak_htabv = traditional_mark_weak_htabv;
748weak_process_fun markhtabvs = traditional_markhtabvs;
749
750void
751install_weak_mark_functions(natural set) {
752  switch(set) {
753  case 0:
754  default:
755    dws_mark_weak_htabv = traditional_dws_mark_htabv;
756    mark_weak_htabv = traditional_mark_weak_htabv;
757    markhtabvs = traditional_markhtabvs;
758    break;
759  case 1:
760    dws_mark_weak_htabv = ncircle_dws_mark_htabv;
761    mark_weak_htabv = ncircle_mark_weak_htabv;
762    markhtabvs = ncircle_markhtabvs;
763    break;
764  }
765}
766
767LispObj
768node_forwarding_address(LispObj node)
769{
770  int tag_n;
771  natural dnode = gc_dynamic_area_dnode(node);
772
773  if ((dnode >= GCndynamic_dnodes_in_area) ||
774      (node < GCfirstunmarked)) {
775    return node;
776  }
777
778  tag_n = fulltag_of(node);
779  if (!is_node_fulltag(tag_n)) {
780    return node;
781  }
782
783  return dnode_forwarding_address(dnode, tag_n);
784}
785
786Boolean
787update_noderef(LispObj *noderef)
788{
789  LispObj
790    node = *noderef,
791    new = node_forwarding_address(node);
792
793  if (new != node) {
794    *noderef = new;
795    return true;
796  }
797  return false;
798}
799
800void
801update_locref(LispObj *locref)
802{
803  LispObj
804    obj = *locref,
805    new = locative_forwarding_address(obj);
806
807  if (new != obj) {
808    *locref = new;
809  }
810}
811
812void
813forward_gcable_ptrs()
814{
815  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new;
816
817  while ((next = *prev) != (LispObj)NULL) {
818    new = node_forwarding_address(next);
819    if (new != next) {
820      *prev = new;
821    }
822    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
823  }
824}
825
826void
827forward_memoized_area(area *a, natural num_memo_dnodes)
828{
829  bitvector refbits = a->refbits;
830  LispObj *p = (LispObj *) a->low, x1, x2, new;
831  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
832  int tag_x1;
833  hash_table_vector_header *hashp = NULL;
834  Boolean header_p;
835
836  if (GCDebug) {
837    check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
838  }
839
840  /* This is pretty straightforward, but we have to note
841     when we move a key in a hash table vector that wants
842     us to tell it about that. */
843
844  set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
845  while (memo_dnode < num_memo_dnodes) {
846    if (bits == 0) {
847      int remain = nbits_in_word - bitidx;
848      memo_dnode += remain;
849      p += (remain+remain);
850      bits = *++bitsp;
851      bitidx = 0;
852    } else {
853      nextbit = count_leading_zeros(bits);
854      if ((diff = (nextbit - bitidx)) != 0) {
855        memo_dnode += diff;
856        bitidx = nextbit;
857        p += (diff+diff);
858      }
859      x1 = p[0];
860      x2 = p[1];
861      tag_x1 = fulltag_of(x1);
862      bits &= ~(BIT0_MASK >> bitidx);
863      header_p = (nodeheader_tag_p(tag_x1));
864
865      if (header_p &&
866          (header_subtag(x1) == subtag_hash_vector)) {
867        hashp = (hash_table_vector_header *) p;
868        if (hashp->flags & nhash_track_keys_mask) {
869          hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
870        } else {
871          hashp = NULL;
872        }
873      }
874
875
876      if (! header_p) {
877        new = node_forwarding_address(x1);
878        if (new != x1) {
879          *p = new;
880        }
881      }
882      p++;
883
884      new = node_forwarding_address(x2);
885      if (new != x2) {
886        *p = new;
887        if (memo_dnode < hash_dnode_limit) {
888          hashp->flags |= nhash_key_moved_mask;
889          hash_dnode_limit = 0;
890          hashp = NULL;
891        }
892      }
893      p++;
894      memo_dnode++;
895      bitidx++;
896
897    }
898  }
899}
900
901void
902forward_tcr_tlb(TCR *tcr)
903{
904  natural n = tcr->tlb_limit;
905  LispObj
906    *start = tcr->tlb_pointer, 
907    *end = (LispObj *) ((BytePtr)start+n),
908    node;
909
910  while (start < end) {
911    node = *start;
912    if (node != no_thread_local_binding_marker) {
913      update_noderef(start);
914    }
915    start++;
916  }
917}
918
919void
920reclaim_static_dnodes()
921{
922  natural nstatic = tenured_area->static_dnodes, i, bits, bitnum;
923  cons *c = (cons *)tenured_area->low, *d;
924  bitvector bitsp = GCmarkbits;
925  LispObj head = lisp_global(STATIC_CONSES);
926
927  if (nstatic) {
928    if (head) {
929      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
930        bits = *bitsp++;
931        if (bits != ALL_ONES) {
932          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
933            if (! (bits & (BIT0_MASK>>bitnum))) {
934              d = c + bitnum;
935              d->car = 0;
936              d->cdr = head;
937              head = ((LispObj)d)+fulltag_cons;
938            }
939          }
940        }
941      }
942      lisp_global(STATIC_CONSES) = head;
943    } else {
944      for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
945        bits = *bitsp++;
946        if (bits != ALL_ONES) {
947          for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
948            if (! (bits & (BIT0_MASK>>bitnum))) {
949              d = c + bitnum;
950              d->car = 0;
951              d->cdr = 0;
952            }
953          }
954        }
955      }
956    }
957  }
958}
959
960Boolean
961youngest_non_null_area_p (area *a)
962{
963  if (a->active == a->high) {
964    return false;
965  } else {
966    for (a = a->younger; a; a = a->younger) {
967      if (a->active != a->high) {
968        return false;
969      }
970    }
971  };
972  return true;
973}
974
975Boolean just_purified_p = false;
976
977/*
978  All thread's stack areas have been "normalized", as
979  has the dynamic heap.  (The "active" pointer in these areas
980  matches the stack pointer/freeptr value at the time that
981  the exception occurred.)
982*/
983
984#ifdef WINDOWS
985#define get_time(when) /* FIXME */
986#else
987#define get_time(when) gettimeofday(&when, NULL)
988#endif
989
990
991#ifdef FORCE_DWS_MARK
992#warning recursive marker disabled for testing; remember to re-enable it
993#endif
994
995
996void 
997gc(TCR *tcr, signed_natural param)
998{
999  struct timeval start, stop;
1000  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1001  unsigned timeidx = 1;
1002  paging_info paging_info_start;
1003  LispObj
1004    pkg = 0,
1005    itabvec = 0;
1006  BytePtr oldfree = a->active;
1007  TCR *other_tcr;
1008  natural static_dnodes;
1009
1010  install_weak_mark_functions(lisp_global(WEAK_GC_METHOD) >> fixnumshift);
1011
1012
1013
1014#ifndef FORCE_DWS_MARK
1015  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1016    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1017  } else {
1018    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
1019  }
1020#else
1021  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1022#endif
1023
1024  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1025  if (GCephemeral_low) {
1026    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1027  } else {
1028    GCn_ephemeral_dnodes = 0;
1029  }
1030 
1031  if (GCn_ephemeral_dnodes) {
1032    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1033  } else {
1034    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1035  }
1036
1037  if (GCephemeral_low) {
1038    if ((oldfree-g1_area->low) < g1_area->threshold) {
1039      to = g1_area;
1040      note = a;
1041      timeidx = 4;
1042    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1043      to = g2_area;
1044      from = g1_area;
1045      note = g1_area;
1046      timeidx = 3;
1047    } else {
1048      to = tenured_area;
1049      from = g2_area;
1050      note = g2_area;
1051      timeidx = 2;
1052    } 
1053  } else {
1054    note = tenured_area;
1055  }
1056
1057  if (GCverbose) {
1058    char buf[16];
1059
1060    sample_paging_info(&paging_info_start);
1061    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1062    if (GCephemeral_low) {
1063      fprintf(stderr,
1064              "\n\n;;; Starting Ephemeral GC of generation %d",
1065              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1066    } else {
1067      fprintf(stderr,"\n\n;;; Starting full GC");
1068    }
1069    fprintf(stderr, ", %s bytes allocated.\n", buf);
1070  }
1071
1072  get_time(start);
1073  lisp_global(IN_GC) = (1<<fixnumshift);
1074
1075  if (just_purified_p) {
1076    just_purified_p = false;
1077    GCDebug = false;
1078  } else {
1079    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1080    if (GCDebug) {
1081      check_all_areas();
1082    }
1083  }
1084
1085  if (from) {
1086    untenure_from_area(from);
1087  }
1088  static_dnodes = static_dnodes_for_area(a);
1089  GCmarkbits = a->markbits;
1090  GCarealow = ptr_to_lispobj(a->low);
1091  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1092  GCndnodes_in_area = gc_area_dnode(oldfree);
1093
1094  if (GCndnodes_in_area) {
1095    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1096    GCdynamic_markbits = 
1097      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1098
1099    zero_bits(GCmarkbits, GCndnodes_in_area);
1100    GCweakvll = (LispObj)NULL;
1101
1102    if (GCn_ephemeral_dnodes == 0) {
1103      /* For GCTWA, mark the internal package hash table vector of
1104       *PACKAGE*, but don't mark its contents. */
1105      {
1106        LispObj
1107          itab;
1108        natural
1109          dnode, ndnodes;
1110     
1111        pkg = nrs_PACKAGE.vcell;
1112        if ((fulltag_of(pkg) == fulltag_misc) &&
1113            (header_subtag(header_of(pkg)) == subtag_package)) {
1114          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1115          itabvec = car(itab);
1116          dnode = gc_area_dnode(itabvec);
1117          if (dnode < GCndnodes_in_area) {
1118            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1119            set_n_bits(GCmarkbits, dnode, ndnodes);
1120          }
1121        }
1122      }
1123    }
1124
1125    mark_root(lisp_global(STATIC_CONSES));
1126
1127    {
1128      area *next_area;
1129      area_code code;
1130
1131      /* Could make a jump table instead of the typecase */
1132
1133      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1134        switch (code) {
1135        case AREA_TSTACK:
1136          mark_tstack_area(next_area);
1137          break;
1138
1139        case AREA_VSTACK:
1140          mark_vstack_area(next_area);
1141          break;
1142         
1143        case AREA_CSTACK:
1144          mark_cstack_area(next_area);
1145          break;
1146
1147        case AREA_STATIC:
1148        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1149          /* In both of these cases, we -could- use the area's "markbits"
1150             bitvector as a reference map.  It's safe (but slower) to
1151             ignore that map and process the entire area.
1152          */
1153          if (next_area->younger == NULL) {
1154            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1155          }
1156          break;
1157
1158        default:
1159          break;
1160        }
1161      }
1162    }
1163 
1164    if (lisp_global(OLDEST_EPHEMERAL)) {
1165      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1166    }
1167
1168    other_tcr = tcr;
1169    do {
1170      mark_tcr_xframes(other_tcr);
1171      mark_tcr_tlb(other_tcr);
1172      other_tcr = other_tcr->next;
1173    } while (other_tcr != tcr);
1174
1175
1176
1177
1178    /* Go back through *package*'s internal symbols, marking
1179       any that aren't worthless.
1180    */
1181   
1182    if (itabvec) {
1183      natural
1184        i,
1185        n = header_element_count(header_of(itabvec));
1186      LispObj
1187        sym,
1188        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1189
1190      for (i = 0; i < n; i++) {
1191        sym = *raw++;
1192        if (is_symbol_fulltag(sym)) {
1193          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1194          natural dnode = gc_area_dnode(sym);
1195         
1196          if ((dnode < GCndnodes_in_area) &&
1197              (!ref_bit(GCmarkbits,dnode))) {
1198            /* Symbol is in GC area, not marked.
1199               Mark it if fboundp, boundp, or if
1200               it has a plist or another home package.
1201            */
1202           
1203            if (FBOUNDP(rawsym) ||
1204                BOUNDP(rawsym) ||
1205                (rawsym->flags != 0) || /* SPECIAL, etc. */
1206                (rawsym->plist != lisp_nil) ||
1207                ((rawsym->package_predicate != pkg) &&
1208                 (rawsym->package_predicate != lisp_nil))) {
1209              mark_root(sym);
1210            }
1211          }
1212        }
1213      }
1214    }
1215
1216    (void)markhtabvs();
1217
1218    if (itabvec) {
1219      natural
1220        i,
1221        n = header_element_count(header_of(itabvec));
1222      LispObj
1223        sym,
1224        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1225
1226      for (i = 0; i < n; i++, raw++) {
1227        sym = *raw;
1228        if (is_symbol_fulltag(sym)) {
1229          natural dnode = gc_area_dnode(sym);
1230
1231          if ((dnode < GCndnodes_in_area) &&
1232              (!ref_bit(GCmarkbits,dnode))) {
1233            *raw = unbound_marker;
1234          }
1235        }
1236      }
1237    }
1238 
1239    reap_gcable_ptrs();
1240
1241    GCrelocptr = global_reloctab;
1242    GCfirstunmarked = calculate_relocation();
1243
1244    if (!GCephemeral_low) {
1245      reclaim_static_dnodes();
1246    }
1247
1248    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1249
1250    other_tcr = tcr;
1251    do {
1252      forward_tcr_xframes(other_tcr);
1253      forward_tcr_tlb(other_tcr);
1254      other_tcr = other_tcr->next;
1255    } while (other_tcr != tcr);
1256
1257 
1258    forward_gcable_ptrs();
1259
1260
1261
1262    {
1263      area *next_area;
1264      area_code code;
1265
1266      /* Could make a jump table instead of the typecase */
1267
1268      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1269        switch (code) {
1270        case AREA_TSTACK:
1271          forward_tstack_area(next_area);
1272          break;
1273
1274        case AREA_VSTACK:
1275          forward_vstack_area(next_area);
1276          break;
1277
1278        case AREA_CSTACK:
1279          forward_cstack_area(next_area);
1280          break;
1281
1282        case AREA_STATIC:
1283        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1284          if (next_area->younger == NULL) {
1285            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1286          }
1287          break;
1288
1289        default:
1290          break;
1291        }
1292      }
1293    }
1294 
1295    if (GCephemeral_low) {
1296      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
1297    }
1298 
1299    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1300    if (to) {
1301      tenure_to_area(to);
1302    }
1303
1304    zero_memory_range(a->active, oldfree);
1305
1306    resize_dynamic_heap(a->active,
1307                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1308
1309    /*
1310      If the EGC is enabled: If there's no room for the youngest
1311      generation, untenure everything.  If this was a full GC and
1312      there's now room for the youngest generation, tenure everything.
1313    */
1314    if (a->older != NULL) {
1315      natural nfree = (a->high - a->active);
1316
1317
1318      if (nfree < a->threshold) {
1319        untenure_from_area(tenured_area);
1320      } else {
1321        if (GCephemeral_low == 0) {
1322          tenure_to_area(tenured_area);
1323        }
1324      }
1325    }
1326  }
1327  lisp_global(GC_NUM) += (1<<fixnumshift);
1328  if (note) {
1329    note->gccount += (1<<fixnumshift);
1330  }
1331
1332  if (GCDebug) {
1333    check_all_areas();
1334  }
1335
1336 
1337  lisp_global(IN_GC) = 0;
1338
1339  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1340  get_time(stop);
1341
1342  {
1343    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1344    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1345    LispObj val;
1346    struct timeval *timeinfo, elapsed;
1347
1348    val = total_gc_microseconds->vcell;
1349    if ((fulltag_of(val) == fulltag_misc) &&
1350        (header_subtag(header_of(val)) == subtag_macptr)) {
1351      timersub(&stop, &start, &elapsed);
1352      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1353      timeradd(timeinfo,  &elapsed, timeinfo);
1354      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1355    }
1356
1357    val = total_bytes_freed->vcell;
1358    if ((fulltag_of(val) == fulltag_misc) &&
1359        (header_subtag(header_of(val)) == subtag_macptr)) {
1360      long long justfreed = oldfree - a->active;
1361      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1362      if (GCverbose) {
1363        char buf[16];
1364        paging_info paging_info_stop;
1365
1366        sample_paging_info(&paging_info_stop);
1367        if (justfreed <= heap_segment_size) {
1368          justfreed = 0;
1369        }
1370        comma_output_decimal(buf,16,justfreed);
1371        if (note == tenured_area) {
1372          fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1373        } else {
1374          fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1375                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1376                  buf, 
1377                  elapsed.tv_sec, elapsed.tv_usec);
1378        }
1379        report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop);
1380      }
1381    }
1382  }
1383}
Note: See TracBrowser for help on using the repository browser.