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

Last change on this file since 14261 was 14197, checked in by rme, 9 years ago

Rename Threads.h to threads.h (with no capital letter).

File size: 45.3 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include "lisp.h"
19#include "lisp_globals.h"
20#include "bits.h"
21#include "gc.h"
22#include "area.h"
23#include "threads.h"
24#include <stddef.h>
25#include <stdlib.h>
26#include <string.h>
27
28#ifndef WINDOWS
29#include <sys/time.h>
30#endif
31
32#ifndef timeradd
33# define timeradd(a, b, result)                                               \
34  do {                                                                        \
35    (result)->tv_sec = (a)->tv_sec + (b)->tv_sec;                             \
36    (result)->tv_usec = (a)->tv_usec + (b)->tv_usec;                          \
37    if ((result)->tv_usec >= 1000000)                                         \
38      {                                                                       \
39        ++(result)->tv_sec;                                                   \
40        (result)->tv_usec -= 1000000;                                         \
41      }                                                                       \
42  } while (0)
43#endif
44#ifndef timersub
45# define timersub(a, b, result)                                               \
46  do {                                                                        \
47    (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;                             \
48    (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;                          \
49    if ((result)->tv_usec < 0) {                                              \
50      --(result)->tv_sec;                                                     \
51      (result)->tv_usec += 1000000;                                           \
52    }                                                                         \
53  } while (0)
54#endif
55
56void
57comma_output_decimal(char *buf, int len, natural n) 
58{
59  int nout = 0;
60
61  buf[--len] = 0;
62  do {
63    buf[--len] = n%10+'0';
64    n = n/10;
65    if (n == 0) {
66      while (len) {
67        buf[--len] = ' ';
68      }
69      return;
70    }
71    if (len == 0) return;
72    nout ++;
73    if (nout == 3) {
74      buf[--len] = ',';
75      nout = 0;
76    }
77  } while (len >= 0);
78}
79
80
81natural
82static_dnodes_for_area(area *a)
83{
84  if (a->low == tenured_area->low) {
85    return tenured_area->static_dnodes;
86  }
87  return 0;
88}
89
90Boolean GCDebug = false, GCverbose = false;
91bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL;
92LispObj GCarealow = 0, GCareadynamiclow = 0;
93natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0;
94LispObj GCweakvll = (LispObj)NULL;
95LispObj GCdwsweakvll = (LispObj)NULL;
96LispObj GCephemeral_low = 0;
97natural GCn_ephemeral_dnodes = 0;
98natural GCstack_limit = 0;
99
100void
101check_static_cons_freelist(char *phase)
102{
103  LispObj
104    n,
105    base = (LispObj)static_cons_area->low, 
106    limit = static_cons_area->ndnodes;
107  natural i=0;
108
109  for (n=lisp_global(STATIC_CONSES);n!=lisp_nil;n=((cons *)untag(n))->cdr, i++) {
110    if ((fulltag_of(n) != fulltag_cons) ||
111        (area_dnode(n,base) >= limit)) {
112      Bug(NULL, "%s: static cons freelist has invalid element 0x" LISP "\n",
113          phase, i);
114    }
115  }
116}
117
118void
119reapweakv(LispObj weakv)
120{
121  /*
122    element 2 of the weak vector should be tagged as a cons: if it
123    isn't, just mark it as a root.  if it is, cdr through it until a
124    "marked" cons is encountered.  If the car of any unmarked cons is
125    marked, mark the cons which contains it; otherwise, splice the
126    cons out of the list.  N.B. : elements 0 and 1 are already marked
127    (or are immediate, etc.)
128  */
129  LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev;
130  LispObj termination_list = lisp_nil;
131  natural weak_type = (natural) deref(weakv,2);
132  Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist),
133    terminatablep = ((weak_type >> population_termination_bit) != 0);
134  Boolean done = false;
135  cons *rawcons;
136  natural dnode, car_dnode;
137  bitvector markbits = GCmarkbits;
138
139  if (terminatablep) {
140    termination_list = deref(weakv,1+3);
141  }
142
143  if (fulltag_of(cell) != fulltag_cons) {
144    mark_root(cell);
145  } else if (alistp) {
146    /* weak alist */
147    while (! done) {
148      dnode = gc_area_dnode(cell);
149      if ((dnode >= GCndnodes_in_area) ||
150          (ref_bit(markbits, dnode))) {
151        done = true;
152      } else {
153        /* Cons cell is unmarked. */
154        LispObj alist_cell, thecar;
155        unsigned cell_tag;
156
157        rawcons = (cons *) ptr_from_lispobj(untag(cell));
158        alist_cell = rawcons->car;
159        cell_tag = fulltag_of(alist_cell);
160
161        if ((cell_tag == fulltag_cons) &&
162            ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) &&
163            (! ref_bit(markbits, car_dnode)) &&
164            (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) &&
165            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
166            (! ref_bit(markbits, car_dnode))) {
167          *prev = rawcons->cdr;
168          if (terminatablep) {
169            rawcons->cdr = termination_list;
170            termination_list = cell;
171          }
172        } else {
173          set_bit(markbits, dnode);
174          prev = (LispObj *)(&(rawcons->cdr));
175          mark_root(alist_cell);
176        }
177        cell = *prev;
178      }
179    }
180  } else {
181    /* weak list */
182    while (! done) {
183      dnode = gc_area_dnode(cell);
184      if ((dnode >= GCndnodes_in_area) ||
185          (ref_bit(markbits, dnode))) {
186        done = true;
187      } else {
188        /* Cons cell is unmarked. */
189        LispObj thecar;
190        unsigned cartag;
191
192        rawcons = (cons *) ptr_from_lispobj(untag(cell));
193        thecar = rawcons->car;
194        cartag = fulltag_of(thecar);
195
196        if (is_node_fulltag(cartag) &&
197            ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) &&
198            (! ref_bit(markbits, car_dnode))) {
199          *prev = rawcons->cdr;
200          if (terminatablep) {
201            rawcons->cdr = termination_list;
202            termination_list = cell;
203          }
204        } else {
205          set_bit(markbits, dnode);
206          prev = (LispObj *)(&(rawcons->cdr));
207        }
208        cell = *prev;
209      }
210    }
211  }
212
213  if (terminatablep) {
214    deref(weakv,1+3) = termination_list;
215  }
216  if (termination_list != lisp_nil) {
217    deref(weakv,1) = GCweakvll;
218    GCweakvll = untag(weakv);
219  } else {
220    deref(weakv,1) = lisp_global(WEAKVLL);
221    lisp_global(WEAKVLL) = untag(weakv);
222  }
223}
224
225/*
226  Screw: doesn't deal with finalization.
227  */
228
229void
230reaphashv(LispObj hashv)
231{
232  hash_table_vector_header
233    *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv));
234  natural
235    dnode;
236  signed_natural
237    npairs = (header_element_count(hashp->header) - 
238              (hash_table_vector_header_count -1)) >> 1;
239  LispObj *pairp = (LispObj*) (hashp+1), weakelement;
240  int weak_index = (((hashp->flags & nhash_weak_value_mask) == 0) ? 0 : 1);
241  Boolean
242    keys_frozen = ((hashp->flags & nhash_keys_frozen_mask) != 0);
243  bitvector markbits = GCmarkbits;
244  int tag;
245
246  natural *tenured_low = (LispObj *)tenured_area->low;
247  natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
248  natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+weak_index), tenured_low);
249  Boolean
250    hashv_tenured = (memo_dnode < tenured_dnodes);
251  natural bits, bitidx, *bitsp;
252
253  if (hashv_tenured) {
254    set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx);
255  }
256
257  while (true) {
258    if (hashv_tenured) {
259      while (bits == 0) {
260        int skip = nbits_in_word - bitidx;
261        npairs -= skip;
262        if (npairs <= 0) break;
263        pairp += (skip+skip);
264        bitidx = 0;
265        bits = *++bitsp;
266      }
267      if (bits != 0) {
268        int skip = (count_leading_zeros(bits) - bitidx);
269        if (skip != 0) {
270          npairs -= skip;
271          pairp += (skip+skip);
272          bitidx += skip;
273        }
274      }
275    }
276
277    if (npairs <= 0) break;
278
279    weakelement = pairp[weak_index];
280    tag = fulltag_of(weakelement);
281    if (is_node_fulltag(tag)) {
282      dnode = gc_area_dnode(weakelement);
283      if ((dnode < GCndnodes_in_area) && 
284          ! ref_bit(markbits, dnode)) {
285        pairp[0] = slot_unbound;
286        if (keys_frozen) {
287          if (pairp[1] != slot_unbound) {
288            pairp[1] = unbound;
289          }
290        }
291        else {
292          pairp[1] = lisp_nil;
293        }
294        hashp->weak_deletions_count += (1<<fixnumshift);
295      }
296    }
297    pairp += 2;
298    --npairs;
299  }
300  deref(hashv, 1) = lisp_global(WEAKVLL);
301  lisp_global(WEAKVLL) = untag(hashv);
302}
303
304void
305traditional_dws_mark_htabv(LispObj htabv)
306{
307  /* Do nothing, just add htabv to GCweakvll */
308  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
309
310  base[1] = GCweakvll;
311  GCweakvll = ptr_to_lispobj(base);
312}
313
314void
315ncircle_dws_mark_htabv(LispObj htabv)
316{
317  /* Do nothing, just add htabv to GCdwsweakvll */
318  deref(htabv,1) = GCdwsweakvll;
319  GCdwsweakvll = htabv;
320}
321
322void
323traditional_mark_weak_htabv(LispObj htabv)
324{
325  int i, skip = hash_table_vector_header_count;;
326  LispObj *base = (LispObj *) ptr_from_lispobj(untag(htabv));
327
328  for (i = 2; i <= skip; i++) {
329    rmark(base[i]);
330  }
331  base[1] = GCweakvll;
332  GCweakvll = ptr_to_lispobj(base);
333}
334
335void
336ncircle_mark_weak_htabv(LispObj htabv)
337{
338  int i, skip = hash_table_vector_header_count;
339  hash_table_vector_header *hashp = (hash_table_vector_header *)(untag(htabv));
340  natural
341    npairs = (header_element_count(hashp->header) - 
342              (hash_table_vector_header_count - 1)) >> 1;
343  LispObj *pairp = (LispObj*) (hashp+1);
344  Boolean
345    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
346
347
348  for (i = 2; i <= skip; i++) {
349    rmark(deref(htabv,i));
350  }
351 
352  if (!weak_on_value) {
353    pairp++;
354  }
355  /* unconditionally mark the non-weak element of each pair */
356  while (npairs--) {
357    rmark(*pairp);
358    pairp += 2;
359  }
360  deref(htabv,1)  = GCweakvll;
361  GCweakvll = (LispObj)untag(htabv);
362}
363
364
365Boolean
366mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements)
367{
368  natural flags = hashp->flags, weak_dnode, nonweak_dnode;
369  Boolean
370    marked_new = false, 
371    weak_marked;
372  int non_weak_index = (((flags & nhash_weak_value_mask) != 0) ? 0 : 1);
373  int 
374    skip = hash_table_vector_header_count-1,
375    weak_tag,
376    nonweak_tag,
377    i;
378  signed_natural
379    npairs = (elements - skip) >> 1;
380  LispObj
381    *pairp = (LispObj*) (hashp+1),
382    weak,
383    nonweak;
384
385  natural *tenured_low = (LispObj *)tenured_area->low;
386  natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
387  natural memo_dnode = area_dnode(ptr_to_lispobj(pairp+non_weak_index), tenured_low);
388  Boolean hashv_tenured = (memo_dnode < tenured_dnodes);
389  natural bits, bitidx, *bitsp;
390
391  if (hashv_tenured) {
392    set_bitidx_vars(tenured_area->refbits, memo_dnode, bitsp, bits, bitidx);
393  }
394
395  /* Mark everything in the header */
396 
397  for (i = 2; i<= skip; i++) {
398    mark_root(deref(ptr_to_lispobj(hashp),i));
399  }
400
401  while (true) {
402    if (hashv_tenured) {
403      while (bits == 0) {
404        int skip = nbits_in_word - bitidx;
405        npairs -= skip;
406        if (npairs <= 0) break;
407        pairp += (skip+skip);
408        bitidx = 0;
409        bits = *++bitsp;
410      }
411      if (bits != 0) {
412        int skip = count_leading_zeros(bits) - bitidx;
413        if (skip != 0) {
414          npairs -= skip;
415          pairp += (skip+skip);
416          bitidx += skip;
417        }
418      }
419    }
420    if (npairs <= 0) break;
421
422    nonweak = pairp[non_weak_index];
423    weak = pairp[1-non_weak_index];
424
425    nonweak_tag = fulltag_of(nonweak);
426    if (is_node_fulltag(nonweak_tag)) {
427      nonweak_dnode = gc_area_dnode(nonweak);
428      if ((nonweak_dnode < GCndnodes_in_area) &&
429          ! ref_bit(GCmarkbits,nonweak_dnode)) {
430        weak_marked = true;
431        weak_tag = fulltag_of(weak);
432        if (is_node_fulltag(weak_tag)) {
433          weak_dnode = gc_area_dnode(weak);
434          if ((weak_dnode < GCndnodes_in_area) &&
435              ! ref_bit(GCmarkbits, weak_dnode)) {
436            weak_marked = false;
437          }
438        }
439        if (weak_marked) {
440          mark_root(nonweak);
441          marked_new = true;
442        }
443      }
444    }
445
446    pairp+=2;
447    --npairs;
448  }
449  return marked_new;
450}
451
452
453Boolean
454mark_weak_alist(LispObj weak_alist, int weak_type)
455{
456  natural
457    elements = header_element_count(header_of(weak_alist)),
458    dnode;
459  int pair_tag;
460  Boolean marked_new = false;
461  LispObj alist, pair, key, value;
462  bitvector markbits = GCmarkbits;
463
464  if (weak_type >> population_termination_bit) {
465    elements -= 1;
466  }
467  for(alist = deref(weak_alist, elements);
468      (fulltag_of(alist) == fulltag_cons) &&
469      ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) &&
470      (! ref_bit(markbits,dnode));
471      alist = cdr(alist)) {
472    pair = car(alist);
473    pair_tag = fulltag_of(pair);
474    if ((is_node_fulltag(pair_tag)) &&
475        ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) &&
476        (! ref_bit(markbits,dnode))) {
477      if (pair_tag == fulltag_cons) {
478        key = car(pair);
479        if ((! is_node_fulltag(fulltag_of(key))) ||
480            ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) ||
481            ref_bit(markbits,dnode)) {
482          /* key is marked, mark value if necessary */
483          value = cdr(pair);
484          if (is_node_fulltag(fulltag_of(value)) &&
485              ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) &&
486              (! ref_bit(markbits,dnode))) {
487            mark_root(value);
488            marked_new = true;
489          }
490        }
491      } else {
492          mark_root(pair);
493          marked_new = true;
494      }
495    }
496  }
497  return marked_new;
498}
499 
500void
501mark_termination_lists()
502{
503  /*
504     Mark the termination lists in all terminatable weak vectors, which
505     are now linked together on GCweakvll, and add them to WEAKVLL,
506     which already contains all other weak vectors.
507  */
508  LispObj pending = GCweakvll,
509          *base = (LispObj *)NULL;
510
511  while (pending) {
512    base = ptr_from_lispobj(pending);
513    pending = base[1];
514
515    mark_root(base[1+3]);
516  }
517  if (base) {
518    base[1] = lisp_global(WEAKVLL);
519    lisp_global(WEAKVLL) = GCweakvll;
520  }
521
522}
523
524
525void
526traditional_markhtabvs()
527{
528  LispObj *base, this, header, pending;
529  int subtag;
530  hash_table_vector_header *hashp;
531  Boolean marked_new;
532
533  do {
534    pending = (LispObj) NULL;
535    marked_new = false;
536   
537    while (GCweakvll) {
538      base = ptr_from_lispobj(GCweakvll);
539      GCweakvll = base[1];
540     
541      header = base[0];
542      subtag = header_subtag(header);
543     
544      if (subtag == subtag_weak) {
545        natural weak_type = base[2];
546        this = ptr_to_lispobj(base) + fulltag_misc;
547        base[1] = pending;
548        pending = ptr_to_lispobj(base);
549        if ((weak_type & population_type_mask) == population_weak_alist) {
550          if (mark_weak_alist(this, weak_type)) {
551            marked_new = true;
552          }
553        }
554      } else if (subtag == subtag_hash_vector) {
555        natural elements = header_element_count(header);
556
557        hashp = (hash_table_vector_header *) base;
558        if (hashp->flags & nhash_weak_mask) {
559          base[1] = pending;
560          pending = ptr_to_lispobj(base);
561          if (mark_weak_hash_vector(hashp, elements)) {
562            marked_new = true;
563          }
564        } 
565      } else {
566        Bug(NULL, "Strange object on weak vector linked list: " LISP "\n", base);
567      }
568    }
569
570    if (marked_new) {
571      GCweakvll = pending;
572    }
573  } while (marked_new);
574
575  /* Now, everything's marked that's going to be,  and "pending" is a list
576     of populations and weak hash tables.  CDR down that list and free
577     anything that isn't marked.
578     */
579
580  while (pending) {
581    base = ptr_from_lispobj(pending);
582    pending = base[1];
583    base[1] = (LispObj)NULL;
584
585    this = ptr_to_lispobj(base) + fulltag_misc;
586
587    subtag = header_subtag(base[0]);
588    if (subtag == subtag_weak) {
589      reapweakv(this);
590    } else {
591      reaphashv(this);
592    }
593  }
594  mark_termination_lists();
595}
596
597void
598ncircle_markhtabvs()
599{
600  LispObj *base, this, header, pending = 0;
601  int subtag;
602
603  /* First, process any weak hash tables that may have
604     been encountered by the link-inverting marker; we
605     should have more stack space now. */
606
607  while (GCdwsweakvll) {
608    this = GCdwsweakvll;
609    GCdwsweakvll = deref(this,1);
610    ncircle_mark_weak_htabv(this);
611  }
612
613  while (GCweakvll) {
614    base = ptr_from_lispobj(GCweakvll);
615    GCweakvll = base[1];
616    base[1] = (LispObj)NULL;
617
618    this = ptr_to_lispobj(base) + fulltag_misc;
619
620    header = base[0];
621    subtag = header_subtag(header);
622     
623    if (subtag == subtag_weak) {
624      natural weak_type = base[2];
625      base[1] = pending;
626      pending = ptr_to_lispobj(base);
627      if ((weak_type & population_type_mask) == population_weak_alist) {
628        mark_weak_alist(this, weak_type);
629      }
630    } else if (subtag == subtag_hash_vector) {
631      reaphashv(this);
632    }
633  }
634
635  /* Now, everything's marked that's going to be,  and "pending" is a list
636     of populations.  CDR down that list and free
637     anything that isn't marked.
638     */
639
640  while (pending) {
641    base = ptr_from_lispobj(pending);
642    pending = base[1];
643    base[1] = (LispObj)NULL;
644
645    this = ptr_to_lispobj(base) + fulltag_misc;
646
647    subtag = header_subtag(base[0]);
648    if (subtag == subtag_weak) {
649      reapweakv(this);
650    } else {
651      Bug(NULL, "Bad object on pending list: %s\n", this);
652    }
653  }
654
655  mark_termination_lists();
656}
657
658void
659mark_tcr_tlb(TCR *tcr)
660{
661  natural n = tcr->tlb_limit;
662  LispObj
663    *start = tcr->tlb_pointer,
664    *end = (LispObj *) ((BytePtr)start+n),
665    node;
666
667  while (start < end) {
668    node = *start;
669    if (node != no_thread_local_binding_marker) {
670      mark_root(node);
671    }
672    start++;
673  }
674}
675
676/*
677  Mark things that're only reachable through some (suspended) TCR.
678  (This basically means the tcr's gc_context and the exception
679  frames on its xframe_list.)
680*/
681
682void
683mark_tcr_xframes(TCR *tcr)
684{
685  xframe_list *xframes;
686  ExceptionInformation *xp;
687
688  xp = tcr->gc_context;
689  if (xp) {
690#ifndef X8632
691    mark_xp(xp);
692#else
693    mark_xp(xp, tcr->node_regs_mask);
694#endif
695  }
696#ifdef X8632
697  mark_root(tcr->save0);
698  mark_root(tcr->save1);
699  mark_root(tcr->save2);
700  mark_root(tcr->save3);
701  mark_root(tcr->next_method_context);
702#endif
703 
704  for (xframes = (xframe_list *) tcr->xframe; 
705       xframes; 
706       xframes = xframes->prev) {
707#ifndef X8632
708      mark_xp(xframes->curr);
709#else
710      mark_xp(xframes->curr, xframes->node_regs_mask);
711#endif
712  }
713}
714     
715
716void *postGCptrs = NULL;
717struct xmacptr *user_postGC_macptrs = NULL;
718
719
720void
721postGCfree(void *p)
722{
723  *(void **)p = postGCptrs;
724  postGCptrs = p;
725}
726
727void
728postGCfreexmacptr(struct xmacptr *p)
729{
730  p->class = (LispObj) user_postGC_macptrs;
731  user_postGC_macptrs = p;
732}
733
734
735xmacptr_dispose_fn xmacptr_dispose_functions[xmacptr_flag_user_last-xmacptr_flag_user_first];
736
737
738
739void
740freeGCptrs()
741{
742  void *p, *next, *addr;
743  struct xmacptr *x, *xnext;
744  int i, flags;
745  xmacptr_dispose_fn dfn;
746
747  for (p = postGCptrs; p; p = next) {
748    next = *((void **)p);
749    free(p);
750  }
751  postGCptrs = NULL;
752 
753  for (x = user_postGC_macptrs; x; x = xnext) {
754    xnext = (xmacptr *) (x->class);;
755    flags = x->flags - xmacptr_flag_user_first;
756    dfn = xmacptr_dispose_functions[flags];
757    addr = (void *) x->address;
758    x->address = 0;
759    x->flags = 0;
760    x->link = 0;
761    x->class = 0;
762    if (dfn && addr) {
763      dfn(addr);
764    }
765  }
766
767  user_postGC_macptrs = NULL;
768}
769
770int
771register_xmacptr_dispose_function(void *dfn)
772{
773  int i, k;
774 
775  for( i = 0, k = xmacptr_flag_user_first; k < xmacptr_flag_user_last; i++, k++) {
776    if (xmacptr_dispose_functions[i]==NULL) {
777      xmacptr_dispose_functions[i] = dfn;
778      return k;
779    }
780    if (xmacptr_dispose_functions[i] == dfn) {
781      return k;
782    }
783  }
784  return 0;
785}
786
787void
788reap_gcable_ptrs()
789{
790  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr;
791  xmacptr_flag flag;
792  natural dnode;
793  xmacptr *x;
794
795  while((next = *prev) != (LispObj)NULL) {
796    dnode = gc_area_dnode(next);
797    x = (xmacptr *) ptr_from_lispobj(untag(next));
798
799    if ((dnode >= GCndnodes_in_area) ||
800        (ref_bit(GCmarkbits,dnode))) {
801      prev = &(x->link);
802    } else {
803      *prev = x->link;
804      flag = (xmacptr_flag)(x->flags);
805      ptr = x->address;
806
807      if (ptr) {
808        switch (flag) {
809        case xmacptr_flag_recursive_lock:
810          destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr));
811          break;
812
813        case xmacptr_flag_ptr:
814          postGCfree((void *)ptr_from_lispobj(ptr));
815          break;
816
817        case xmacptr_flag_rwlock:
818          rwlock_destroy((rwlock *)ptr_from_lispobj(ptr));
819          break;
820
821        case xmacptr_flag_semaphore:
822          destroy_semaphore((void**)&(x->address));
823          break;
824
825        default:
826          if ((flag >= xmacptr_flag_user_first) &&
827              (flag < xmacptr_flag_user_last)) {
828            set_n_bits(GCmarkbits,dnode,3);
829            postGCfreexmacptr(x);
830            break;
831          }
832          /* (warn "unknown xmacptr_flag: ~s" flag) */
833          /* Unknowd, and perhaps unknowdable. */
834          /* Fall in: */
835        case xmacptr_flag_none:
836          break;
837        }
838      }
839    }
840  }
841}
842
843
844
845#if  WORD_SIZE == 64
846unsigned short *_one_bits = NULL;
847
848unsigned short
849logcount16(unsigned short n)
850{
851  unsigned short c=0;
852 
853  while(n) {
854    n = n & (n-1);
855    c++;
856  }
857  return c;
858}
859
860void
861gc_init()
862{
863  int i;
864 
865  _one_bits = malloc(sizeof(unsigned short) * (1<<16));
866
867  for (i = 0; i < (1<<16); i++) {
868    _one_bits[i] = dnode_size*logcount16(i);
869  }
870}
871
872
873#else
874const unsigned char _one_bits[256] = {
875    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,
876    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,
877    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,
878    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,
879    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,
880    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,
881    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,
882    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,
883    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,
884    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,
885    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,
886    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,
887    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,
888    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,
889    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,
890    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
891};
892
893
894void
895gc_init()
896{
897}
898
899#endif
900
901
902weak_mark_fun dws_mark_weak_htabv = traditional_dws_mark_htabv;
903weak_mark_fun mark_weak_htabv = traditional_mark_weak_htabv;
904weak_process_fun markhtabvs = traditional_markhtabvs;
905
906void
907install_weak_mark_functions(natural set) {
908  switch(set) {
909  case 0:
910  default:
911    dws_mark_weak_htabv = traditional_dws_mark_htabv;
912    mark_weak_htabv = traditional_mark_weak_htabv;
913    markhtabvs = traditional_markhtabvs;
914    break;
915  case 1:
916    dws_mark_weak_htabv = ncircle_dws_mark_htabv;
917    mark_weak_htabv = ncircle_mark_weak_htabv;
918    markhtabvs = ncircle_markhtabvs;
919    break;
920  }
921}
922
923void
924init_weakvll ()
925{
926  LispObj this = lisp_global(WEAKVLL); /* all weak vectors as of last gc */
927
928  GCweakvll = (LispObj)NULL;
929  lisp_global(WEAKVLL) = (LispObj)NULL;
930
931  if (GCn_ephemeral_dnodes) {
932    /* For egc case, initialize GCweakvll with weak vectors not in the
933       GC area.  Weak vectors in the GC area will be added during marking.
934    */
935
936    LispObj *tenured_low = (LispObj *)tenured_area->low;
937    natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
938    bitvector refbits = tenured_area->refbits;
939
940    while (this) {
941      LispObj *base = ptr_from_lispobj(this);
942      LispObj next = base[1];
943      natural dnode = gc_dynamic_area_dnode(this);
944      if (dnode < GCndynamic_dnodes_in_area) {
945        base[1] = (LispObj)NULL; /* drop it, might be garbage */
946      } else {
947        base[1] = GCweakvll;
948        GCweakvll = ptr_to_lispobj(base);
949        if (header_subtag(base[0]) == subtag_weak) {
950          dnode = area_dnode(&base[3], tenured_low);
951          if (dnode < tenured_dnodes) {
952            clr_bit(refbits, dnode); /* Don't treat population.data as root */
953          }
954        } else {
955          if (header_subtag(base[0]) != subtag_hash_vector)
956            Bug(NULL, "Unexpected entry " LISP " -> " LISP " on WEAKVLL", base, base[0]);
957          dnode = area_dnode(base, tenured_low);
958          if ((dnode < tenured_dnodes) && !ref_bit(refbits, dnode)) {
959            Boolean drop = true;
960            /* hash vectors get marked headers if they have any ephemeral keys */
961            /* but not if they have ephemeral values. */
962            if (((hash_table_vector_header *)base)->flags & nhash_weak_value_mask) {
963              signed_natural count = (header_element_count(base[0]) + 2) >> 1;
964              natural bits, bitidx, *bitsp;
965              set_bitidx_vars(refbits, dnode, bitsp, bits, bitidx);
966              while ((0 < count) && (bits == 0)) {
967                int skip = nbits_in_word - bitidx;
968                count -= skip;
969                bits = *++bitsp;
970                bitidx = 0;
971              }
972              count -=  (count_leading_zeros(bits) - bitidx);
973
974              if (0 < count) {
975                set_bit(refbits, dnode); /* has ephemeral values, mark header */
976                drop = false;
977              }
978            }
979            if (drop) { /* if nothing ephemeral, drop it from GCweakvll. */
980              GCweakvll = base[1];
981              base[1] = lisp_global(WEAKVLL);
982              lisp_global(WEAKVLL) = ptr_to_lispobj(base);
983            }
984          }
985        }
986      }
987      this = next;
988    }
989  }
990}
991
992 
993void
994preforward_weakvll ()
995{
996  /* reset population refbits for forwarding */
997  if (GCn_ephemeral_dnodes) {
998    LispObj this = lisp_global(WEAKVLL);
999    LispObj *tenured_low = (LispObj *)tenured_area->low;
1000    natural tenured_dnodes = area_dnode(GCarealow, tenured_low);
1001    bitvector refbits = tenured_area->refbits;
1002
1003    while (this) {
1004      LispObj *base = ptr_from_lispobj(this);
1005      if (header_subtag(base[0]) == subtag_weak) {
1006        natural dnode = area_dnode(&base[3], tenured_low);
1007        if (base[3] >= GCarealow) {
1008          if (dnode < tenured_dnodes) {
1009            set_bit(refbits, dnode);
1010          }
1011        }
1012        /* might have set termination list to a new pointer */
1013        if ((base[2] >> population_termination_bit) && (base[4] >= GCarealow)) {
1014          if ((dnode + 1) < tenured_dnodes) {
1015            set_bit(refbits, dnode+1);
1016          }
1017        }
1018      }
1019      this = base[1];
1020    }
1021  }
1022}
1023
1024
1025void
1026forward_weakvll_links()
1027{
1028  LispObj *ptr = &(lisp_global(WEAKVLL)), this, new, old;
1029
1030  while (this = *ptr) {
1031    old = this + fulltag_misc;
1032    new = node_forwarding_address(old);
1033    if (old != new) {
1034      *ptr = untag(new);
1035    }
1036    ptr = &(deref(new,1));
1037  }
1038}
1039
1040
1041
1042
1043
1044LispObj
1045node_forwarding_address(LispObj node)
1046{
1047  int tag_n;
1048  natural dnode = gc_dynamic_area_dnode(node);
1049
1050  if ((dnode >= GCndynamic_dnodes_in_area) ||
1051      (node < GCfirstunmarked)) {
1052    return node;
1053  }
1054
1055  tag_n = fulltag_of(node);
1056  if (!is_node_fulltag(tag_n)) {
1057    return node;
1058  }
1059
1060  return dnode_forwarding_address(dnode, tag_n);
1061}
1062
1063Boolean
1064update_noderef(LispObj *noderef)
1065{
1066  LispObj
1067    node = *noderef,
1068    new = node_forwarding_address(node);
1069
1070  if (new != node) {
1071    *noderef = new;
1072    return true;
1073  }
1074  return false;
1075}
1076
1077void
1078update_locref(LispObj *locref)
1079{
1080  LispObj
1081    obj = *locref,
1082    new = locative_forwarding_address(obj);
1083
1084  if (new != obj) {
1085    *locref = new;
1086  }
1087}
1088
1089void
1090forward_gcable_ptrs()
1091{
1092  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new;
1093  struct xmacptr **xprev, *xnext, *xnew;
1094
1095  while ((next = *prev) != (LispObj)NULL) {
1096    new = node_forwarding_address(next);
1097    if (new != next) {
1098      *prev = new;
1099    }
1100    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
1101  }
1102  xprev = &user_postGC_macptrs;
1103  while (xnext = *xprev) {
1104    xnew = (struct xmacptr *)locative_forwarding_address((LispObj)xnext);
1105    if (xnew != xnext) {
1106      *xprev = xnew;
1107    }
1108    xprev = (struct xmacptr **)(&(xnext->class));
1109  }
1110}
1111
1112void
1113forward_memoized_area(area *a, natural num_memo_dnodes)
1114{
1115  bitvector refbits = a->refbits;
1116  LispObj *p = (LispObj *) a->low, x1, x2, new;
1117  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
1118  int tag_x1;
1119  hash_table_vector_header *hashp = NULL;
1120  Boolean header_p;
1121
1122  if (num_memo_dnodes) {
1123    if (GCDebug) {
1124      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1125    }
1126
1127    /* This is pretty straightforward, but we have to note
1128       when we move a key in a hash table vector that wants
1129       us to tell it about that. */
1130
1131    set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1132    while (memo_dnode < num_memo_dnodes) {
1133      if (bits == 0) {
1134        int remain = nbits_in_word - bitidx;
1135        memo_dnode += remain;
1136        p += (remain+remain);
1137        bits = *++bitsp;
1138        bitidx = 0;
1139      } else {
1140        nextbit = count_leading_zeros(bits);
1141        if ((diff = (nextbit - bitidx)) != 0) {
1142          memo_dnode += diff;
1143          bitidx = nextbit;
1144          p += (diff+diff);
1145        }
1146        x1 = p[0];
1147        x2 = p[1];
1148        tag_x1 = fulltag_of(x1);
1149        bits &= ~(BIT0_MASK >> bitidx);
1150        header_p = (nodeheader_tag_p(tag_x1));
1151
1152        if (header_p &&
1153            (header_subtag(x1) == subtag_hash_vector)) {
1154          hashp = (hash_table_vector_header *) p;
1155          if (hashp->flags & nhash_track_keys_mask) {
1156            hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
1157          } else {
1158            hashp = NULL;
1159          }
1160        }
1161
1162
1163        if (! header_p) {
1164          new = node_forwarding_address(x1);
1165          if (new != x1) {
1166            *p = new;
1167          }
1168        }
1169        p++;
1170
1171        new = node_forwarding_address(x2);
1172        if (new != x2) {
1173          *p = new;
1174          if (memo_dnode < hash_dnode_limit) {
1175            /* If this code is reached, 'hashp' is non-NULL and pointing
1176               at the header of a hash_table_vector, and 'memo_dnode' identifies
1177               a pair of words inside the hash_table_vector.  It may be
1178               hard for program analysis tools to recognize that, but I
1179               believe that warnings about 'hashp' being NULL here can
1180               be safely ignored. */
1181            hashp->flags |= nhash_key_moved_mask;
1182            hash_dnode_limit = 0;
1183            hashp = NULL;
1184          }
1185        }
1186        p++;
1187        memo_dnode++;
1188        bitidx++;
1189
1190      }
1191    }
1192  }
1193}
1194
1195void
1196forward_tcr_tlb(TCR *tcr)
1197{
1198  natural n = tcr->tlb_limit;
1199  LispObj
1200    *start = tcr->tlb_pointer, 
1201    *end = (LispObj *) ((BytePtr)start+n),
1202    node;
1203
1204  while (start < end) {
1205    node = *start;
1206    if (node != no_thread_local_binding_marker) {
1207      update_noderef(start);
1208    }
1209    start++;
1210  }
1211}
1212
1213void
1214reclaim_static_dnodes()
1215{
1216  natural nstatic = tenured_area->static_dnodes, 
1217    i, 
1218    bits, 
1219    bitnum,
1220    nfree = 0,
1221    nstatic_conses = area_dnode(static_cons_area->high, static_cons_area->low);
1222  cons *c = (cons *)tenured_area->low, *d;
1223  bitvector bitsp = GCmarkbits;
1224  LispObj head = lisp_global(STATIC_CONSES);
1225
1226  for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
1227    bits = *bitsp++;
1228    if (bits != ALL_ONES) {
1229      for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
1230        if (! (bits & (BIT0_MASK>>bitnum))) {
1231          d = c + bitnum;
1232          if (i < nstatic_conses) {               
1233            d->car = unbound;
1234            d->cdr = head;
1235            head = ((LispObj)d)+fulltag_cons;
1236            nfree++;
1237          } else {
1238            d->car = 0;
1239            d->cdr = 0;
1240          }
1241        }
1242      }
1243    }
1244  }
1245  lisp_global(STATIC_CONSES) = head;
1246  lisp_global(FREE_STATIC_CONSES)+=(nfree<<fixnumshift);
1247}
1248
1249Boolean
1250youngest_non_null_area_p (area *a)
1251{
1252  if (a->active == a->high) {
1253    return false;
1254  } else {
1255    for (a = a->younger; a; a = a->younger) {
1256      if (a->active != a->high) {
1257        return false;
1258      }
1259    }
1260  };
1261  return true;
1262}
1263
1264Boolean just_purified_p = false;
1265
1266/*
1267  All thread's stack areas have been "normalized", as
1268  has the dynamic heap.  (The "active" pointer in these areas
1269  matches the stack pointer/freeptr value at the time that
1270  the exception occurred.)
1271*/
1272
1273#define get_time(when) gettimeofday(&when, NULL)
1274
1275
1276
1277#ifdef FORCE_DWS_MARK
1278#warning recursive marker disabled for testing; remember to re-enable it
1279#endif
1280
1281
1282Boolean
1283mark_static_ref(LispObj n, BytePtr dynamic_start, natural ndynamic_dnodes)
1284{
1285  int tag_n = fulltag_of(n);
1286  natural dyn_dnode;
1287
1288  if (nodeheader_tag_p(tag_n)) {
1289    return (header_subtag(n) == subtag_hash_vector);
1290  }
1291 
1292  if (is_node_fulltag (tag_n)) {
1293    dyn_dnode = area_dnode(n, dynamic_start);
1294    if (dyn_dnode < ndynamic_dnodes) {
1295      mark_root(n);             /* May or may not mark it */
1296      return true;              /* but return true 'cause it's a dynamic node */
1297    }
1298  }
1299  return false;                 /* Not a heap pointer or not dynamic */
1300}
1301
1302void
1303mark_managed_static_refs(area *a, BytePtr low_dynamic_address, natural ndynamic_dnodes)
1304{
1305  bitvector refbits = a->refbits;
1306  LispObj *p = (LispObj *) a->low, x1, x2;
1307  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0,
1308    num_memo_dnodes = a->ndnodes;
1309  Boolean keep_x1, keep_x2;
1310
1311  if (num_memo_dnodes) {
1312    if (GCDebug) {
1313      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1314    }
1315
1316 
1317    set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1318    inbits = outbits = bits;
1319    while (memo_dnode < num_memo_dnodes) {
1320      if (bits == 0) {
1321        int remain = nbits_in_word - bitidx;
1322        memo_dnode += remain;
1323        p += (remain+remain);
1324        if (outbits != inbits) {
1325          *bitsp = outbits;
1326        }
1327        bits = *++bitsp;
1328        inbits = outbits = bits;
1329        bitidx = 0;
1330      } else {
1331        nextbit = count_leading_zeros(bits);
1332        if ((diff = (nextbit - bitidx)) != 0) {
1333          memo_dnode += diff;
1334          bitidx = nextbit;
1335          p += (diff+diff);
1336        }
1337        x1 = *p++;
1338        x2 = *p++;
1339        bits &= ~(BIT0_MASK >> bitidx);
1340        keep_x1 = mark_static_ref(x1, low_dynamic_address, ndynamic_dnodes);
1341        keep_x2 = mark_static_ref(x2, low_dynamic_address, ndynamic_dnodes);
1342        if ((keep_x1 == false) && 
1343            (keep_x2 == false)) {
1344          outbits &= ~(BIT0_MASK >> bitidx);
1345        }
1346        memo_dnode++;
1347        bitidx++;
1348      }
1349    }
1350    if (GCDebug) {
1351      p = (LispObj *) a->low;
1352      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1353    }
1354  }
1355}
1356
1357void 
1358gc(TCR *tcr, signed_natural param)
1359{
1360  struct timeval start, stop;
1361  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1362  unsigned timeidx = 1;
1363  paging_info paging_info_start;
1364  LispObj
1365    pkg = 0,
1366    itabvec = 0;
1367  BytePtr oldfree = a->active, last_zeroed_addr;
1368  TCR *other_tcr;
1369  natural static_dnodes;
1370  natural weak_method = lisp_global(WEAK_GC_METHOD) >> fixnumshift;
1371
1372#ifndef FORCE_DWS_MARK
1373  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1374    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1375  } else {
1376    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
1377  }
1378#else
1379  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1380#endif
1381
1382  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1383  if (GCephemeral_low) {
1384    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1385  } else {
1386    GCn_ephemeral_dnodes = 0;
1387  }
1388 
1389  if (GCn_ephemeral_dnodes) {
1390    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1391  } else {
1392    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1393  }
1394
1395  if (GCephemeral_low) {
1396    if ((oldfree-g1_area->low) < g1_area->threshold) {
1397      to = g1_area;
1398      note = a;
1399      timeidx = 4;
1400    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1401      to = g2_area;
1402      from = g1_area;
1403      note = g1_area;
1404      timeidx = 3;
1405    } else {
1406      to = tenured_area;
1407      from = g2_area;
1408      note = g2_area;
1409      timeidx = 2;
1410    } 
1411  } else {
1412    note = tenured_area;
1413  }
1414
1415  install_weak_mark_functions(weak_method);
1416 
1417  if (GCverbose) {
1418    char buf[16];
1419
1420    sample_paging_info(&paging_info_start);
1421    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1422    if (GCephemeral_low) {
1423      fprintf(dbgout,
1424              "\n\n;;; Starting Ephemeral GC of generation %d",
1425              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1426    } else {
1427      fprintf(dbgout,"\n\n;;; Starting full GC");
1428    }
1429    fprintf(dbgout, ", %s bytes allocated.\n", buf);
1430  }
1431
1432  get_time(start);
1433
1434  /* The link-inverting marker might need to write to watched areas */
1435  unprotect_watched_areas();
1436
1437  lisp_global(IN_GC) = (1<<fixnumshift);
1438
1439  if (just_purified_p) {
1440    just_purified_p = false;
1441    GCDebug = false;
1442  } else {
1443    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1444    if (GCDebug) {
1445      check_all_areas(tcr);
1446      check_static_cons_freelist("in pre-gc static-cons check");
1447    }
1448  }
1449
1450  if (from) {
1451    untenure_from_area(from);
1452  }
1453  static_dnodes = static_dnodes_for_area(a);
1454  GCmarkbits = a->markbits;
1455  GCarealow = ptr_to_lispobj(a->low);
1456  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1457  GCndnodes_in_area = gc_area_dnode(oldfree);
1458
1459  if (GCndnodes_in_area) {
1460    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1461    GCdynamic_markbits = 
1462      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1463
1464    zero_bits(GCmarkbits, GCndnodes_in_area);
1465
1466    init_weakvll();
1467
1468    if (GCn_ephemeral_dnodes == 0) {
1469      /* For GCTWA, mark the internal package hash table vector of
1470       *PACKAGE*, but don't mark its contents. */
1471      {
1472        LispObj
1473          itab,
1474          pkgidx = nrs_PACKAGE.binding_index;
1475        natural
1476          dnode, ndnodes;
1477     
1478        if ((pkgidx >= tcr->tlb_limit) ||
1479            ((pkg = tcr->tlb_pointer[pkgidx>>fixnumshift]) == 
1480             no_thread_local_binding_marker)) {
1481          pkg = nrs_PACKAGE.vcell;
1482        }
1483        if ((fulltag_of(pkg) == fulltag_misc) &&
1484            (header_subtag(header_of(pkg)) == subtag_package)) {
1485          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1486          itabvec = car(itab);
1487          dnode = gc_area_dnode(itabvec);
1488          if (dnode < GCndnodes_in_area) {
1489            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1490            set_n_bits(GCmarkbits, dnode, ndnodes);
1491          }
1492        }
1493      }
1494    }
1495
1496    mark_root(lisp_global(STATIC_CONSES));
1497
1498    {
1499      area *next_area;
1500      area_code code;
1501
1502      /* Could make a jump table instead of the typecase */
1503
1504      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1505        switch (code) {
1506        case AREA_TSTACK:
1507          mark_tstack_area(next_area);
1508          break;
1509
1510        case AREA_VSTACK:
1511          mark_vstack_area(next_area);
1512          break;
1513         
1514        case AREA_CSTACK:
1515          mark_cstack_area(next_area);
1516          break;
1517
1518        case AREA_STATIC:
1519        case AREA_WATCHED:
1520        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1521          /* In both of these cases, we -could- use the area's "markbits"
1522             bitvector as a reference map.  It's safe (but slower) to
1523             ignore that map and process the entire area.
1524          */
1525          if (next_area->younger == NULL) {
1526            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1527          }
1528          break;
1529
1530        default:
1531          break;
1532        }
1533      }
1534    }
1535 
1536    if (GCephemeral_low) {
1537      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1538    }
1539
1540    mark_managed_static_refs(managed_static_area,low_markable_address,area_dnode(a->active,low_markable_address));
1541   
1542    other_tcr = tcr;
1543    do {
1544      mark_tcr_xframes(other_tcr);
1545      mark_tcr_tlb(other_tcr);
1546      other_tcr = other_tcr->next;
1547    } while (other_tcr != tcr);
1548
1549
1550
1551
1552    /* Go back through *package*'s internal symbols, marking
1553       any that aren't worthless.
1554    */
1555   
1556    if (itabvec) {
1557      natural
1558        i,
1559        n = header_element_count(header_of(itabvec));
1560      LispObj
1561        sym,
1562        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1563
1564      for (i = 0; i < n; i++) {
1565        sym = *raw++;
1566        if (is_symbol_fulltag(sym)) {
1567          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1568          natural dnode = gc_area_dnode(sym);
1569         
1570          if ((dnode < GCndnodes_in_area) &&
1571              (!ref_bit(GCmarkbits,dnode))) {
1572            /* Symbol is in GC area, not marked.
1573               Mark it if fboundp, boundp, or if
1574               it has a plist or another home package.
1575            */
1576           
1577            if (FBOUNDP(rawsym) ||
1578                BOUNDP(rawsym) ||
1579                (rawsym->flags != 0) || /* SPECIAL, etc. */
1580                (rawsym->plist != lisp_nil) ||
1581                ((rawsym->package_predicate != pkg) &&
1582                 (rawsym->package_predicate != lisp_nil))) {
1583              mark_root(sym);
1584            }
1585          }
1586        }
1587      }
1588    }
1589
1590    (void)markhtabvs();
1591
1592    if (itabvec) {
1593      natural
1594        i,
1595        n = header_element_count(header_of(itabvec));
1596      LispObj
1597        sym,
1598        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1599
1600      for (i = 0; i < n; i++, raw++) {
1601        sym = *raw;
1602        if (is_symbol_fulltag(sym)) {
1603          natural dnode = gc_area_dnode(sym);
1604
1605          if ((dnode < GCndnodes_in_area) &&
1606              (!ref_bit(GCmarkbits,dnode))) {
1607            *raw = unbound_marker;
1608          }
1609        }
1610      }
1611    }
1612 
1613    reap_gcable_ptrs();
1614
1615    preforward_weakvll();
1616
1617    GCrelocptr = global_reloctab;
1618    GCfirstunmarked = calculate_relocation();
1619
1620    if (!GCephemeral_low) {
1621      reclaim_static_dnodes();
1622    }
1623
1624    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1625
1626    other_tcr = tcr;
1627    do {
1628      forward_tcr_xframes(other_tcr);
1629      forward_tcr_tlb(other_tcr);
1630      other_tcr = other_tcr->next;
1631    } while (other_tcr != tcr);
1632
1633 
1634    forward_gcable_ptrs();
1635
1636
1637
1638    {
1639      area *next_area;
1640      area_code code;
1641
1642      /* Could make a jump table instead of the typecase */
1643
1644      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1645        switch (code) {
1646        case AREA_TSTACK:
1647          forward_tstack_area(next_area);
1648          break;
1649
1650        case AREA_VSTACK:
1651          forward_vstack_area(next_area);
1652          break;
1653
1654        case AREA_CSTACK:
1655          forward_cstack_area(next_area);
1656          break;
1657
1658        case AREA_STATIC:
1659        case AREA_WATCHED:
1660        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1661          if (next_area->younger == NULL) {
1662            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1663          }
1664          break;
1665
1666        default:
1667          break;
1668        }
1669      }
1670    }
1671
1672    if (GCephemeral_low) {
1673      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
1674    }
1675 
1676    forward_memoized_area(managed_static_area,area_dnode(managed_static_area->active,managed_static_area->low));
1677    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1678
1679    forward_weakvll_links();
1680
1681    if (to) {
1682      tenure_to_area(to);
1683    }
1684
1685
1686    resize_dynamic_heap(a->active,
1687                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1688
1689    if (oldfree < a->high) {
1690      last_zeroed_addr = oldfree;
1691    } else {
1692      last_zeroed_addr = a->high;
1693    }
1694    zero_memory_range(a->active, last_zeroed_addr);
1695
1696    /*
1697      If the EGC is enabled: If there's no room for the youngest
1698      generation, untenure everything.  If this was a full GC and
1699      there's now room for the youngest generation, tenure everything.
1700    */
1701    if (a->older != NULL) {
1702      natural nfree = (a->high - a->active);
1703
1704
1705      if (nfree < a->threshold) {
1706        untenure_from_area(tenured_area);
1707      } else {
1708        if (GCephemeral_low == 0) {
1709          tenure_to_area(tenured_area);
1710        }
1711      }
1712    }
1713  }
1714  lisp_global(GC_NUM) += (1<<fixnumshift);
1715  if (note) {
1716    note->gccount += (1<<fixnumshift);
1717  }
1718
1719  if (GCDebug) {
1720    check_all_areas(tcr);
1721    check_static_cons_freelist("in post-gc static-cons check");
1722  }
1723
1724 
1725  lisp_global(IN_GC) = 0;
1726 
1727  protect_watched_areas();
1728
1729  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1730  get_time(stop);
1731
1732  {
1733    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1734    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1735    LispObj val;
1736    struct timeval *timeinfo, elapsed = {0, 0};
1737
1738    val = total_gc_microseconds->vcell;
1739    if ((fulltag_of(val) == fulltag_misc) &&
1740        (header_subtag(header_of(val)) == subtag_macptr)) {
1741      timersub(&stop, &start, &elapsed);
1742      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1743      timeradd(timeinfo,  &elapsed, timeinfo);
1744      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1745    }
1746
1747    val = total_bytes_freed->vcell;
1748    if ((fulltag_of(val) == fulltag_misc) &&
1749        (header_subtag(header_of(val)) == subtag_macptr)) {
1750      long long justfreed = oldfree - a->active;
1751      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1752      if (GCverbose) {
1753        char buf[16];
1754        paging_info paging_info_stop;
1755
1756        sample_paging_info(&paging_info_stop);
1757        if (justfreed <= heap_segment_size) {
1758          justfreed = 0;
1759        }
1760        comma_output_decimal(buf,16,justfreed);
1761        if (note == tenured_area) {
1762          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1763        } else {
1764          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1765                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1766                  buf, 
1767                  elapsed.tv_sec, elapsed.tv_usec);
1768        }
1769        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
1770      }
1771    }
1772  }
1773}
Note: See TracBrowser for help on using the repository browser.