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

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

New file: try to isolate GC code common to all platforms.

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