source: branches/working-0711/ccl/lisp-kernel/gc-common.c @ 9958

Last change on this file since 9958 was 9958, checked in by gb, 11 years ago

Import code from trunk (most changes have to do with weak htab
marking strategies.)

Remove some unused variables, to limit warnings when compiled with -Wall.

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 = {0, 0};
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.