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

Last change on this file since 14347 was 14295, checked in by rme, 9 years ago

Eliminate some (but not all) warnings produced when building with
"-Wall -Wno-format". Also a couple of minor changes that enable
clang to build the lisp kernel (at least on x8632 and x8664).

File size: 45.6 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 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#ifdef ARM
1118  LispObj *p0 = p;
1119#endif
1120  natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0;
1121  int tag_x1;
1122  hash_table_vector_header *hashp = NULL;
1123  Boolean header_p;
1124
1125  if (num_memo_dnodes) {
1126    if (GCDebug) {
1127      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1128    }
1129
1130    /* This is pretty straightforward, but we have to note
1131       when we move a key in a hash table vector that wants
1132       us to tell it about that. */
1133
1134    set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1135    while (memo_dnode < num_memo_dnodes) {
1136      if (bits == 0) {
1137        int remain = nbits_in_word - bitidx;
1138        memo_dnode += remain;
1139        p += (remain+remain);
1140        bits = *++bitsp;
1141        bitidx = 0;
1142      } else {
1143        nextbit = count_leading_zeros(bits);
1144        if ((diff = (nextbit - bitidx)) != 0) {
1145          memo_dnode += diff;
1146          bitidx = nextbit;
1147          p += (diff+diff);
1148        }
1149        x1 = p[0];
1150        x2 = p[1];
1151        tag_x1 = fulltag_of(x1);
1152        bits &= ~(BIT0_MASK >> bitidx);
1153        header_p = (nodeheader_tag_p(tag_x1));
1154
1155        if (header_p &&
1156            (header_subtag(x1) == subtag_hash_vector)) {
1157          hashp = (hash_table_vector_header *) p;
1158          if (hashp->flags & nhash_track_keys_mask) {
1159            hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1);
1160          } else {
1161            hashp = NULL;
1162          }
1163        }
1164
1165
1166        if (! header_p) {
1167          new = node_forwarding_address(x1);
1168          if (new != x1) {
1169            *p = new;
1170#ifdef ARM
1171            if (p != p0) {
1172              if(header_subtag(p[-2]) == subtag_function) {
1173                /* Just updated the code vector; fix the entrypoint */
1174                if (p[-1] == (untag(x1)+fulltag_odd_fixnum)) {
1175                  p[-1] = (untag(new)+fulltag_odd_fixnum);
1176                }
1177              }
1178            }
1179#endif
1180          }
1181        }
1182        p++;
1183
1184        new = node_forwarding_address(x2);
1185        if (new != x2) {
1186          *p = new;
1187          if (memo_dnode < hash_dnode_limit) {
1188            /* If this code is reached, 'hashp' is non-NULL and pointing
1189               at the header of a hash_table_vector, and 'memo_dnode' identifies
1190               a pair of words inside the hash_table_vector.  It may be
1191               hard for program analysis tools to recognize that, but I
1192               believe that warnings about 'hashp' being NULL here can
1193               be safely ignored. */
1194            hashp->flags |= nhash_key_moved_mask;
1195            hash_dnode_limit = 0;
1196            hashp = NULL;
1197          }
1198        }
1199        p++;
1200        memo_dnode++;
1201        bitidx++;
1202
1203      }
1204    }
1205  }
1206}
1207
1208void
1209forward_tcr_tlb(TCR *tcr)
1210{
1211  natural n = tcr->tlb_limit;
1212  LispObj
1213    *start = tcr->tlb_pointer, 
1214    *end = (LispObj *) ((BytePtr)start+n),
1215    node;
1216
1217  while (start < end) {
1218    node = *start;
1219    if (node != no_thread_local_binding_marker) {
1220      update_noderef(start);
1221    }
1222    start++;
1223  }
1224}
1225
1226void
1227reclaim_static_dnodes()
1228{
1229  natural nstatic = tenured_area->static_dnodes, 
1230    i, 
1231    bits, 
1232    bitnum,
1233    nfree = 0,
1234    nstatic_conses = area_dnode(static_cons_area->high, static_cons_area->low);
1235  cons *c = (cons *)tenured_area->low, *d;
1236  bitvector bitsp = GCmarkbits;
1237  LispObj head = lisp_global(STATIC_CONSES);
1238
1239  for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) {
1240    bits = *bitsp++;
1241    if (bits != ALL_ONES) {
1242      for (bitnum = 0; bitnum < nbits_in_word; bitnum++) {
1243        if (! (bits & (BIT0_MASK>>bitnum))) {
1244          d = c + bitnum;
1245          if (i < nstatic_conses) {               
1246            d->car = unbound;
1247            d->cdr = head;
1248            head = ((LispObj)d)+fulltag_cons;
1249            nfree++;
1250          } else {
1251            d->car = 0;
1252            d->cdr = 0;
1253          }
1254        }
1255      }
1256    }
1257  }
1258  lisp_global(STATIC_CONSES) = head;
1259  lisp_global(FREE_STATIC_CONSES)+=(nfree<<fixnumshift);
1260}
1261
1262Boolean
1263youngest_non_null_area_p (area *a)
1264{
1265  if (a->active == a->high) {
1266    return false;
1267  } else {
1268    for (a = a->younger; a; a = a->younger) {
1269      if (a->active != a->high) {
1270        return false;
1271      }
1272    }
1273  };
1274  return true;
1275}
1276
1277Boolean just_purified_p = false;
1278
1279/*
1280  All thread's stack areas have been "normalized", as
1281  has the dynamic heap.  (The "active" pointer in these areas
1282  matches the stack pointer/freeptr value at the time that
1283  the exception occurred.)
1284*/
1285
1286#define get_time(when) gettimeofday(&when, NULL)
1287
1288
1289
1290#ifdef FORCE_DWS_MARK
1291#warning recursive marker disabled for testing; remember to re-enable it
1292#endif
1293
1294
1295Boolean
1296mark_static_ref(LispObj n, BytePtr dynamic_start, natural ndynamic_dnodes)
1297{
1298  int tag_n = fulltag_of(n);
1299  natural dyn_dnode;
1300
1301  if (nodeheader_tag_p(tag_n)) {
1302    return (header_subtag(n) == subtag_hash_vector);
1303  }
1304 
1305  if (is_node_fulltag (tag_n)) {
1306    dyn_dnode = area_dnode(n, dynamic_start);
1307    if (dyn_dnode < ndynamic_dnodes) {
1308      mark_root(n);             /* May or may not mark it */
1309      return true;              /* but return true 'cause it's a dynamic node */
1310    }
1311  }
1312  return false;                 /* Not a heap pointer or not dynamic */
1313}
1314
1315void
1316mark_managed_static_refs(area *a, BytePtr low_dynamic_address, natural ndynamic_dnodes)
1317{
1318  bitvector refbits = a->refbits;
1319  LispObj *p = (LispObj *) a->low, x1, x2;
1320  natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0,
1321    num_memo_dnodes = a->ndnodes;
1322  Boolean keep_x1, keep_x2;
1323
1324  if (num_memo_dnodes) {
1325    if (GCDebug) {
1326      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1327    }
1328
1329 
1330    set_bitidx_vars(refbits, 0, bitsp, bits, bitidx);
1331    inbits = outbits = bits;
1332    while (memo_dnode < num_memo_dnodes) {
1333      if (bits == 0) {
1334        int remain = nbits_in_word - bitidx;
1335        memo_dnode += remain;
1336        p += (remain+remain);
1337        if (outbits != inbits) {
1338          *bitsp = outbits;
1339        }
1340        bits = *++bitsp;
1341        inbits = outbits = bits;
1342        bitidx = 0;
1343      } else {
1344        nextbit = count_leading_zeros(bits);
1345        if ((diff = (nextbit - bitidx)) != 0) {
1346          memo_dnode += diff;
1347          bitidx = nextbit;
1348          p += (diff+diff);
1349        }
1350        x1 = *p++;
1351        x2 = *p++;
1352        bits &= ~(BIT0_MASK >> bitidx);
1353        keep_x1 = mark_static_ref(x1, low_dynamic_address, ndynamic_dnodes);
1354        keep_x2 = mark_static_ref(x2, low_dynamic_address, ndynamic_dnodes);
1355        if ((keep_x1 == false) && 
1356            (keep_x2 == false)) {
1357          outbits &= ~(BIT0_MASK >> bitidx);
1358        }
1359        memo_dnode++;
1360        bitidx++;
1361      }
1362    }
1363    if (GCDebug) {
1364      p = (LispObj *) a->low;
1365      check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits);
1366    }
1367  }
1368}
1369
1370void 
1371gc(TCR *tcr, signed_natural param)
1372{
1373  struct timeval start, stop;
1374  area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL;
1375  unsigned timeidx = 1;
1376  paging_info paging_info_start;
1377  LispObj
1378    pkg = 0,
1379    itabvec = 0;
1380  BytePtr oldfree = a->active, last_zeroed_addr;
1381  TCR *other_tcr;
1382  natural static_dnodes;
1383  natural weak_method = lisp_global(WEAK_GC_METHOD) >> fixnumshift;
1384
1385#ifndef FORCE_DWS_MARK
1386  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
1387    GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1388  } else {
1389    GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size;
1390  }
1391#else
1392  GCstack_limit = CS_OVERFLOW_FORCE_LIMIT;
1393#endif
1394
1395  GCephemeral_low = lisp_global(OLDEST_EPHEMERAL);
1396  if (GCephemeral_low) {
1397    GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low);
1398  } else {
1399    GCn_ephemeral_dnodes = 0;
1400  }
1401 
1402  if (GCn_ephemeral_dnodes) {
1403    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0);
1404  } else {
1405    GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0);
1406  }
1407
1408  if (GCephemeral_low) {
1409    if ((oldfree-g1_area->low) < g1_area->threshold) {
1410      to = g1_area;
1411      note = a;
1412      timeidx = 4;
1413    } else if ((oldfree-g2_area->low) < g2_area->threshold) {
1414      to = g2_area;
1415      from = g1_area;
1416      note = g1_area;
1417      timeidx = 3;
1418    } else {
1419      to = tenured_area;
1420      from = g2_area;
1421      note = g2_area;
1422      timeidx = 2;
1423    } 
1424  } else {
1425    note = tenured_area;
1426  }
1427
1428  install_weak_mark_functions(weak_method);
1429 
1430  if (GCverbose) {
1431    char buf[16];
1432
1433    sample_paging_info(&paging_info_start);
1434    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
1435    if (GCephemeral_low) {
1436      fprintf(dbgout,
1437              "\n\n;;; Starting Ephemeral GC of generation %d",
1438              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); 
1439    } else {
1440      fprintf(dbgout,"\n\n;;; Starting full GC");
1441    }
1442    fprintf(dbgout, ", %s bytes allocated.\n", buf);
1443  }
1444
1445  get_time(start);
1446
1447  /* The link-inverting marker might need to write to watched areas */
1448  unprotect_watched_areas();
1449
1450  lisp_global(IN_GC) = (1<<fixnumshift);
1451
1452  if (just_purified_p) {
1453    just_purified_p = false;
1454    GCDebug = false;
1455  } else {
1456    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
1457    if (GCDebug) {
1458      check_all_areas(tcr);
1459      check_static_cons_freelist("in pre-gc static-cons check");
1460    }
1461  }
1462
1463  if (from) {
1464    untenure_from_area(from);
1465  }
1466  static_dnodes = static_dnodes_for_area(a);
1467  GCmarkbits = a->markbits;
1468  GCarealow = ptr_to_lispobj(a->low);
1469  GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift);
1470  GCndnodes_in_area = gc_area_dnode(oldfree);
1471
1472  if (GCndnodes_in_area) {
1473    GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes;
1474    GCdynamic_markbits = 
1475      GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift);
1476
1477    zero_bits(GCmarkbits, GCndnodes_in_area);
1478
1479    init_weakvll();
1480
1481    if (GCn_ephemeral_dnodes == 0) {
1482      /* For GCTWA, mark the internal package hash table vector of
1483       *PACKAGE*, but don't mark its contents. */
1484      {
1485        LispObj
1486          itab,
1487          pkgidx = nrs_PACKAGE.binding_index;
1488        natural
1489          dnode, ndnodes;
1490     
1491        if ((pkgidx >= tcr->tlb_limit) ||
1492            ((pkg = tcr->tlb_pointer[pkgidx>>fixnumshift]) == 
1493             no_thread_local_binding_marker)) {
1494          pkg = nrs_PACKAGE.vcell;
1495        }
1496        if ((fulltag_of(pkg) == fulltag_misc) &&
1497            (header_subtag(header_of(pkg)) == subtag_package)) {
1498          itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab;
1499          itabvec = car(itab);
1500          dnode = gc_area_dnode(itabvec);
1501          if (dnode < GCndnodes_in_area) {
1502            ndnodes = (header_element_count(header_of(itabvec))+1) >> 1;
1503            set_n_bits(GCmarkbits, dnode, ndnodes);
1504          }
1505        }
1506      }
1507    }
1508
1509    mark_root(lisp_global(STATIC_CONSES));
1510
1511    {
1512      area *next_area;
1513      area_code code;
1514
1515      /* Could make a jump table instead of the typecase */
1516
1517      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1518        switch (code) {
1519        case AREA_TSTACK:
1520          mark_tstack_area(next_area);
1521          break;
1522
1523        case AREA_VSTACK:
1524          mark_vstack_area(next_area);
1525          break;
1526         
1527        case AREA_CSTACK:
1528          mark_cstack_area(next_area);
1529          break;
1530
1531        case AREA_STATIC:
1532        case AREA_WATCHED:
1533        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1534          /* In both of these cases, we -could- use the area's "markbits"
1535             bitvector as a reference map.  It's safe (but slower) to
1536             ignore that map and process the entire area.
1537          */
1538          if (next_area->younger == NULL) {
1539            mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1540          }
1541          break;
1542
1543        default:
1544          break;
1545        }
1546      }
1547    }
1548 
1549    if (GCephemeral_low) {
1550      mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low));
1551    }
1552
1553    mark_managed_static_refs(managed_static_area,low_markable_address,area_dnode(a->active,low_markable_address));
1554   
1555    other_tcr = tcr;
1556    do {
1557      mark_tcr_xframes(other_tcr);
1558      mark_tcr_tlb(other_tcr);
1559      other_tcr = other_tcr->next;
1560    } while (other_tcr != tcr);
1561
1562
1563
1564
1565    /* Go back through *package*'s internal symbols, marking
1566       any that aren't worthless.
1567    */
1568   
1569    if (itabvec) {
1570      natural
1571        i,
1572        n = header_element_count(header_of(itabvec));
1573      LispObj
1574        sym,
1575        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1576
1577      for (i = 0; i < n; i++) {
1578        sym = *raw++;
1579        if (is_symbol_fulltag(sym)) {
1580          lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym));
1581          natural dnode = gc_area_dnode(sym);
1582         
1583          if ((dnode < GCndnodes_in_area) &&
1584              (!ref_bit(GCmarkbits,dnode))) {
1585            /* Symbol is in GC area, not marked.
1586               Mark it if fboundp, boundp, or if
1587               it has a plist or another home package.
1588            */
1589           
1590            if (FBOUNDP(rawsym) ||
1591                BOUNDP(rawsym) ||
1592                (rawsym->flags != 0) || /* SPECIAL, etc. */
1593                (rawsym->plist != lisp_nil) ||
1594                ((rawsym->package_predicate != pkg) &&
1595                 (rawsym->package_predicate != lisp_nil))) {
1596              mark_root(sym);
1597            }
1598          }
1599        }
1600      }
1601    }
1602
1603    (void)markhtabvs();
1604
1605    if (itabvec) {
1606      natural
1607        i,
1608        n = header_element_count(header_of(itabvec));
1609      LispObj
1610        sym,
1611        *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec)));
1612
1613      for (i = 0; i < n; i++, raw++) {
1614        sym = *raw;
1615        if (is_symbol_fulltag(sym)) {
1616          natural dnode = gc_area_dnode(sym);
1617
1618          if ((dnode < GCndnodes_in_area) &&
1619              (!ref_bit(GCmarkbits,dnode))) {
1620            *raw = unbound_marker;
1621          }
1622        }
1623      }
1624    }
1625 
1626    reap_gcable_ptrs();
1627
1628    preforward_weakvll();
1629
1630    GCrelocptr = global_reloctab;
1631    GCfirstunmarked = calculate_relocation();
1632
1633    if (!GCephemeral_low) {
1634      reclaim_static_dnodes();
1635    }
1636
1637    forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked));
1638
1639    other_tcr = tcr;
1640    do {
1641      forward_tcr_xframes(other_tcr);
1642      forward_tcr_tlb(other_tcr);
1643      other_tcr = other_tcr->next;
1644    } while (other_tcr != tcr);
1645
1646 
1647    forward_gcable_ptrs();
1648
1649
1650
1651    {
1652      area *next_area;
1653      area_code code;
1654
1655      /* Could make a jump table instead of the typecase */
1656
1657      for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) {
1658        switch (code) {
1659        case AREA_TSTACK:
1660          forward_tstack_area(next_area);
1661          break;
1662
1663        case AREA_VSTACK:
1664          forward_vstack_area(next_area);
1665          break;
1666
1667        case AREA_CSTACK:
1668          forward_cstack_area(next_area);
1669          break;
1670
1671        case AREA_STATIC:
1672        case AREA_WATCHED:
1673        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
1674          if (next_area->younger == NULL) {
1675            forward_range((LispObj *) next_area->low, (LispObj *) next_area->active);
1676          }
1677          break;
1678
1679        default:
1680          break;
1681        }
1682      }
1683    }
1684
1685    if (GCephemeral_low) {
1686      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
1687    }
1688 
1689    forward_memoized_area(managed_static_area,area_dnode(managed_static_area->active,managed_static_area->low));
1690    a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap());
1691
1692    forward_weakvll_links();
1693
1694    if (to) {
1695      tenure_to_area(to);
1696    }
1697
1698
1699    resize_dynamic_heap(a->active,
1700                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
1701
1702    if (oldfree < a->high) {
1703      last_zeroed_addr = oldfree;
1704    } else {
1705      last_zeroed_addr = a->high;
1706    }
1707    zero_memory_range(a->active, last_zeroed_addr);
1708
1709    /*
1710      If the EGC is enabled: If there's no room for the youngest
1711      generation, untenure everything.  If this was a full GC and
1712      there's now room for the youngest generation, tenure everything.
1713    */
1714    if (a->older != NULL) {
1715      natural nfree = (a->high - a->active);
1716
1717
1718      if (nfree < a->threshold) {
1719        untenure_from_area(tenured_area);
1720      } else {
1721        if (GCephemeral_low == 0) {
1722          tenure_to_area(tenured_area);
1723        }
1724      }
1725    }
1726  }
1727  lisp_global(GC_NUM) += (1<<fixnumshift);
1728  if (note) {
1729    note->gccount += (1<<fixnumshift);
1730  }
1731
1732  if (GCDebug) {
1733    check_all_areas(tcr);
1734    check_static_cons_freelist("in post-gc static-cons check");
1735  }
1736
1737 
1738  lisp_global(IN_GC) = 0;
1739 
1740  protect_watched_areas();
1741
1742  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
1743  get_time(stop);
1744
1745  {
1746    lispsymbol * total_gc_microseconds = (lispsymbol *) &(nrs_TOTAL_GC_MICROSECONDS);
1747    lispsymbol * total_bytes_freed = (lispsymbol *) &(nrs_TOTAL_BYTES_FREED);
1748    LispObj val;
1749    struct timeval *timeinfo, elapsed = {0, 0};
1750
1751    val = total_gc_microseconds->vcell;
1752    if ((fulltag_of(val) == fulltag_misc) &&
1753        (header_subtag(header_of(val)) == subtag_macptr)) {
1754      timersub(&stop, &start, &elapsed);
1755      timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address);
1756      timeradd(timeinfo,  &elapsed, timeinfo);
1757      timeradd(timeinfo+timeidx,  &elapsed, timeinfo+timeidx);
1758    }
1759
1760    val = total_bytes_freed->vcell;
1761    if ((fulltag_of(val) == fulltag_misc) &&
1762        (header_subtag(header_of(val)) == subtag_macptr)) {
1763      long long justfreed = oldfree - a->active;
1764      *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed;
1765      if (GCverbose) {
1766        char buf[16];
1767        paging_info paging_info_stop;
1768
1769        sample_paging_info(&paging_info_stop);
1770        if (justfreed <= heap_segment_size) {
1771          justfreed = 0;
1772        }
1773        comma_output_decimal(buf,16,justfreed);
1774        if (note == tenured_area) {
1775          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
1776        } else {
1777          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", 
1778                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
1779                  buf, 
1780                  elapsed.tv_sec, elapsed.tv_usec);
1781        }
1782        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
1783      }
1784    }
1785  }
1786}
Note: See TracBrowser for help on using the repository browser.